New upstream version 4.04.0

diff --git a/.depend b/.depend
index 43f0a1c61e63f2d69d21f3ee3c07b736bf1d4e8d..45132604aff545a3de0180bd06eeec67df087d64 100644 (file)
--- a/.depend
+++ b/.depend
@@ -1,87 +1,68 @@
+utils/arg_helper.cmo : utils/arg_helper.cmi
+utils/arg_helper.cmx : utils/arg_helper.cmi
 utils/arg_helper.cmi :
-utils/ccomp.cmi :
-utils/clflags.cmi : utils/misc.cmi
-utils/config.cmi :
-utils/consistbl.cmi :
-utils/identifiable.cmi :
-utils/misc.cmi :
-utils/numbers.cmi : utils/identifiable.cmi
-utils/strongly_connected_components.cmi : utils/identifiable.cmi
-utils/tbl.cmi :
-utils/terminfo.cmi :
-utils/timings.cmi :
-utils/warnings.cmi :
-utils/arg_helper.cmo : utils/misc.cmi utils/arg_helper.cmi
-utils/arg_helper.cmx : utils/misc.cmx utils/arg_helper.cmi
 utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \
     utils/ccomp.cmi
 utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \
     utils/ccomp.cmi
+utils/ccomp.cmi :
 utils/clflags.cmo : utils/numbers.cmi utils/misc.cmi utils/config.cmi \
     utils/arg_helper.cmi utils/clflags.cmi
 utils/clflags.cmx : utils/numbers.cmx utils/misc.cmx utils/config.cmx \
     utils/arg_helper.cmx utils/clflags.cmi
+utils/clflags.cmi : utils/misc.cmi
 utils/config.cmo : utils/config.cmi
 utils/config.cmx : utils/config.cmi
+utils/config.cmi :
 utils/consistbl.cmo : utils/consistbl.cmi
 utils/consistbl.cmx : utils/consistbl.cmi
+utils/consistbl.cmi :
 utils/identifiable.cmo : utils/misc.cmi utils/identifiable.cmi
 utils/identifiable.cmx : utils/misc.cmx utils/identifiable.cmi
+utils/identifiable.cmi :
 utils/misc.cmo : utils/misc.cmi
 utils/misc.cmx : utils/misc.cmi
+utils/misc.cmi :
 utils/numbers.cmo : utils/identifiable.cmi utils/numbers.cmi
 utils/numbers.cmx : utils/identifiable.cmx utils/numbers.cmi
+utils/numbers.cmi : utils/identifiable.cmi
 utils/strongly_connected_components.cmo : utils/numbers.cmi utils/misc.cmi \
     utils/identifiable.cmi utils/strongly_connected_components.cmi
 utils/strongly_connected_components.cmx : utils/numbers.cmx utils/misc.cmx \
     utils/identifiable.cmx utils/strongly_connected_components.cmi
+utils/strongly_connected_components.cmi : utils/identifiable.cmi
 utils/tbl.cmo : utils/tbl.cmi
 utils/tbl.cmx : utils/tbl.cmi
+utils/tbl.cmi :
 utils/terminfo.cmo : utils/terminfo.cmi
 utils/terminfo.cmx : utils/terminfo.cmi
+utils/terminfo.cmi :
 utils/timings.cmo : utils/timings.cmi
 utils/timings.cmx : utils/timings.cmi
+utils/timings.cmi :
 utils/warnings.cmo : utils/misc.cmi utils/warnings.cmi
 utils/warnings.cmx : utils/misc.cmx utils/warnings.cmi
-parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \
-    parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi
-parsing/ast_invariants.cmi : parsing/parsetree.cmi
-parsing/ast_iterator.cmi : parsing/parsetree.cmi parsing/location.cmi
-parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi
-parsing/asttypes.cmi : parsing/location.cmi
-parsing/attr_helper.cmi : parsing/parsetree.cmi parsing/location.cmi \
-    parsing/asttypes.cmi
-parsing/builtin_attributes.cmi : parsing/parsetree.cmi parsing/location.cmi \
-    parsing/ast_iterator.cmi
-parsing/docstrings.cmi : parsing/parsetree.cmi parsing/location.cmi
-parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi
-parsing/location.cmi : utils/warnings.cmi
-parsing/longident.cmi :
-parsing/parse.cmi : parsing/parsetree.cmi
-parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi \
-    parsing/docstrings.cmi
-parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \
-    parsing/asttypes.cmi
-parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \
-    parsing/asttypes.cmi
-parsing/printast.cmi : parsing/parsetree.cmi
-parsing/syntaxerr.cmi : parsing/location.cmi
+utils/warnings.cmi :
 parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \
     parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi \
     parsing/ast_helper.cmi
 parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \
     parsing/location.cmx parsing/docstrings.cmx parsing/asttypes.cmi \
     parsing/ast_helper.cmi
+parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \
+    parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi
 parsing/ast_invariants.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
     parsing/longident.cmi parsing/builtin_attributes.cmi parsing/asttypes.cmi \
     parsing/ast_iterator.cmi parsing/ast_invariants.cmi
 parsing/ast_invariants.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \
     parsing/longident.cmx parsing/builtin_attributes.cmx parsing/asttypes.cmi \
     parsing/ast_iterator.cmx parsing/ast_invariants.cmi
+parsing/ast_invariants.cmi : parsing/parsetree.cmi
 parsing/ast_iterator.cmo : parsing/parsetree.cmi parsing/location.cmi \
     parsing/ast_iterator.cmi
 parsing/ast_iterator.cmx : parsing/parsetree.cmi parsing/location.cmx \
     parsing/ast_iterator.cmi
+parsing/ast_iterator.cmi : parsing/parsetree.cmi parsing/location.cmi
 parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi utils/config.cmi \
     utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
@@ -90,36 +71,54 @@ parsing/ast_mapper.cmx : parsing/parsetree.cmi utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx utils/config.cmx \
     utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
     parsing/ast_mapper.cmi
+parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi
+parsing/asttypes.cmi : parsing/location.cmi
 parsing/attr_helper.cmo : parsing/parsetree.cmi parsing/location.cmi \
     parsing/asttypes.cmi parsing/attr_helper.cmi
 parsing/attr_helper.cmx : parsing/parsetree.cmi parsing/location.cmx \
     parsing/asttypes.cmi parsing/attr_helper.cmi
+parsing/attr_helper.cmi : parsing/parsetree.cmi parsing/location.cmi \
+    parsing/asttypes.cmi
 parsing/builtin_attributes.cmo : utils/warnings.cmi parsing/parsetree.cmi \
     parsing/location.cmi parsing/asttypes.cmi parsing/ast_iterator.cmi \
     parsing/builtin_attributes.cmi
 parsing/builtin_attributes.cmx : utils/warnings.cmx parsing/parsetree.cmi \
     parsing/location.cmx parsing/asttypes.cmi parsing/ast_iterator.cmx \
     parsing/builtin_attributes.cmi
+parsing/builtin_attributes.cmi : parsing/parsetree.cmi parsing/location.cmi \
+    parsing/ast_iterator.cmi
+parsing/depend.cmo : parsing/parsetree.cmi utils/misc.cmi \
+    parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \
+    parsing/builtin_attributes.cmi parsing/asttypes.cmi parsing/depend.cmi
+parsing/depend.cmx : parsing/parsetree.cmi utils/misc.cmx \
+    parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \
+    parsing/builtin_attributes.cmx parsing/asttypes.cmi parsing/depend.cmi
+parsing/depend.cmi : parsing/parsetree.cmi parsing/longident.cmi
 parsing/docstrings.cmo : utils/warnings.cmi parsing/parsetree.cmi \
     parsing/location.cmi parsing/docstrings.cmi
 parsing/docstrings.cmx : utils/warnings.cmx parsing/parsetree.cmi \
     parsing/location.cmx parsing/docstrings.cmi
+parsing/docstrings.cmi : parsing/parsetree.cmi parsing/location.cmi
 parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
     parsing/location.cmi parsing/docstrings.cmi parsing/lexer.cmi
 parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
     parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi
+parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi
 parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi utils/misc.cmi \
     utils/clflags.cmi parsing/location.cmi
 parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx utils/misc.cmx \
     utils/clflags.cmx parsing/location.cmi
+parsing/location.cmi : utils/warnings.cmi
 parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi
 parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi
+parsing/longident.cmi :
 parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \
     parsing/location.cmi parsing/lexer.cmi parsing/docstrings.cmi \
     parsing/parse.cmi
 parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \
     parsing/location.cmx parsing/lexer.cmx parsing/docstrings.cmx \
     parsing/parse.cmi
+parsing/parse.cmi : parsing/parsetree.cmi
 parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
     parsing/longident.cmi parsing/location.cmi parsing/docstrings.cmi \
     utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
@@ -128,95 +127,38 @@ parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \
     parsing/longident.cmx parsing/location.cmx parsing/docstrings.cmx \
     utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
     parsing/parser.cmi
+parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi \
+    parsing/docstrings.cmi
+parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \
+    parsing/asttypes.cmi
 parsing/pprintast.cmo : parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
     parsing/pprintast.cmi
 parsing/pprintast.cmx : parsing/parsetree.cmi utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \
     parsing/pprintast.cmi
+parsing/pprintast.cmi : parsing/parsetree.cmi
 parsing/printast.cmo : parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
     parsing/printast.cmi
 parsing/printast.cmx : parsing/parsetree.cmi utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \
     parsing/printast.cmi
+parsing/printast.cmi : parsing/parsetree.cmi
 parsing/syntaxerr.cmo : parsing/location.cmi parsing/syntaxerr.cmi
 parsing/syntaxerr.cmx : parsing/location.cmx parsing/syntaxerr.cmi
+parsing/syntaxerr.cmi : parsing/location.cmi
 typing/annot.cmi : parsing/location.cmi
-typing/btype.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi
-typing/cmi_format.cmi : typing/types.cmi
-typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \
-    parsing/location.cmi typing/env.cmi typing/cmi_format.cmi
-typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
-    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
-typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
-typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
-    typing/path.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi
-typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
-typing/ident.cmi : utils/identifiable.cmi
-typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
-typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
-    typing/ident.cmi typing/env.cmi
-typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \
-    typing/path.cmi parsing/location.cmi typing/includecore.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi
-typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \
-    typing/env.cmi
-typing/oprint.cmi : typing/outcometree.cmi
-typing/outcometree.cmi : parsing/asttypes.cmi
-typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/env.cmi parsing/asttypes.cmi
-typing/path.cmi : typing/ident.cmi
-typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
-typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \
-    parsing/location.cmi
-typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
-    typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
-    typing/env.cmi parsing/asttypes.cmi
-typing/printtyped.cmi : typing/typedtree.cmi
-typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
-    typing/annot.cmi
-typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
-typing/tast_mapper.cmi : typing/typedtree.cmi typing/env.cmi \
-    parsing/asttypes.cmi
-typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
-typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi
-typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/includecore.cmi typing/ident.cmi typing/env.cmi \
-    parsing/asttypes.cmi
-typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
-typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
-typing/typedtreeMap.cmi : typing/typedtree.cmi
-typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/includemod.cmi typing/ident.cmi typing/env.cmi \
-    parsing/asttypes.cmi
-typing/types.cmi : typing/primitive.cmi typing/path.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/ident.cmi parsing/asttypes.cmi
-typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/env.cmi parsing/asttypes.cmi
-typing/untypeast.cmi : typing/typedtree.cmi typing/path.cmi \
-    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
-    parsing/asttypes.cmi
 typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \
     typing/ident.cmi parsing/asttypes.cmi typing/btype.cmi
 typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \
     typing/ident.cmx parsing/asttypes.cmi typing/btype.cmi
+typing/btype.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi
 typing/cmi_format.cmo : typing/types.cmi parsing/location.cmi \
     utils/config.cmi typing/cmi_format.cmi
 typing/cmi_format.cmx : typing/types.cmx parsing/location.cmx \
     utils/config.cmx typing/cmi_format.cmi
+typing/cmi_format.cmi : typing/types.cmi
 typing/cmt_format.cmo : typing/types.cmi typing/typedtree.cmi \
     typing/tast_mapper.cmi utils/misc.cmi parsing/location.cmi \
     parsing/lexer.cmi typing/env.cmi utils/config.cmi typing/cmi_format.cmi \
@@ -225,6 +167,8 @@ typing/cmt_format.cmx : typing/types.cmx typing/typedtree.cmx \
     typing/tast_mapper.cmx utils/misc.cmx parsing/location.cmx \
     parsing/lexer.cmx typing/env.cmx utils/config.cmx typing/cmi_format.cmx \
     utils/clflags.cmx typing/cmt_format.cmi
+typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \
+    parsing/location.cmi typing/env.cmi typing/cmi_format.cmi
 typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/predef.cmi \
     typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi typing/env.cmi utils/clflags.cmi typing/btype.cmi \
@@ -233,12 +177,15 @@ typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/predef.cmx \
     typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
     typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \
     parsing/asttypes.cmi typing/ctype.cmi
+typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
+    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
 typing/datarepr.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \
     typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi \
     typing/datarepr.cmi
 typing/datarepr.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \
     typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \
     typing/datarepr.cmi
+typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
 typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
     typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
@@ -251,26 +198,33 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
     typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
     typing/cmi_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
     typing/btype.cmx parsing/asttypes.cmi typing/env.cmi
+typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
+    typing/path.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi utils/consistbl.cmi typing/cmi_format.cmi \
+    parsing/asttypes.cmi
 typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
     typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \
     parsing/asttypes.cmi typing/envaux.cmi
 typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
     typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \
     parsing/asttypes.cmi typing/envaux.cmi
+typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
 typing/ident.cmo : utils/identifiable.cmi typing/ident.cmi
 typing/ident.cmx : utils/identifiable.cmx typing/ident.cmi
+typing/ident.cmi : utils/identifiable.cmi
 typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
     typing/ctype.cmi typing/includeclass.cmi
 typing/includeclass.cmx : typing/types.cmx typing/printtyp.cmx \
     typing/ctype.cmx typing/includeclass.cmi
+typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
 typing/includecore.cmo : typing/types.cmi typing/typedtree.cmi \
-    typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \
-    typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \
-    typing/includecore.cmi
+    typing/path.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+    typing/btype.cmi parsing/asttypes.cmi typing/includecore.cmi
 typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \
-    typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \
-    typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \
-    typing/includecore.cmi
+    typing/path.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+    typing/btype.cmx parsing/asttypes.cmi typing/includecore.cmi
+typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
+    typing/ident.cmi typing/env.cmi
 typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
     typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi typing/path.cmi \
     typing/mtype.cmi utils/misc.cmi parsing/location.cmi \
@@ -283,6 +237,9 @@ typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
     typing/includecore.cmx typing/includeclass.cmx typing/ident.cmx \
     typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \
     typing/includemod.cmi
+typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \
+    typing/path.cmi parsing/location.cmi typing/includecore.cmi \
+    typing/ident.cmi typing/env.cmi typing/ctype.cmi
 typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \
     utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
     typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
@@ -291,10 +248,14 @@ typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \
     utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
     typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
     typing/mtype.cmi
+typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \
+    typing/env.cmi
 typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \
     typing/oprint.cmi
 typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \
     typing/oprint.cmi
+typing/oprint.cmi : typing/outcometree.cmi
+typing/outcometree.cmi : parsing/asttypes.cmi
 typing/parmatch.cmo : utils/warnings.cmi typing/untypeast.cmi \
     typing/types.cmi typing/typedtreeIter.cmi typing/typedtree.cmi \
     typing/subst.cmi typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
@@ -307,52 +268,70 @@ typing/parmatch.cmx : utils/warnings.cmx typing/untypeast.cmx \
     utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
     typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/btype.cmx \
     parsing/asttypes.cmi parsing/ast_helper.cmx typing/parmatch.cmi
+typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/env.cmi parsing/asttypes.cmi
 typing/path.cmo : typing/ident.cmi typing/path.cmi
 typing/path.cmx : typing/ident.cmx typing/path.cmi
+typing/path.cmi : typing/ident.cmi
 typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
     parsing/location.cmi typing/ident.cmi typing/btype.cmi \
     parsing/asttypes.cmi typing/predef.cmi
 typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/parsetree.cmi \
     parsing/location.cmx typing/ident.cmx typing/btype.cmx \
     parsing/asttypes.cmi typing/predef.cmi
+typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
 typing/primitive.cmo : utils/warnings.cmi parsing/parsetree.cmi \
     typing/outcometree.cmi utils/misc.cmi parsing/location.cmi \
     parsing/attr_helper.cmi typing/primitive.cmi
 typing/primitive.cmx : utils/warnings.cmx parsing/parsetree.cmi \
     typing/outcometree.cmi utils/misc.cmx parsing/location.cmx \
     parsing/attr_helper.cmx typing/primitive.cmi
+typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \
+    parsing/location.cmi
 typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
     typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
     typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
-    typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \
-    parsing/asttypes.cmi typing/printtyp.cmi
+    typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
+    parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \
+    typing/printtyp.cmi
 typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \
     typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \
     typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
-    typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
-    parsing/asttypes.cmi typing/printtyp.cmi
+    typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
+    parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \
+    typing/printtyp.cmi
+typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
+    typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
+    typing/env.cmi parsing/asttypes.cmi
 typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \
     typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi
 typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \
     typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
     typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi
+typing/printtyped.cmi : typing/typedtree.cmi
 typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \
     parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
 typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \
     parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi
+typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
+    typing/annot.cmi
 typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \
     utils/misc.cmi parsing/location.cmi typing/ident.cmi utils/clflags.cmi \
     typing/btype.cmi parsing/ast_mapper.cmi typing/subst.cmi
 typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \
     utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi
+typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
 typing/tast_mapper.cmo : typing/typedtree.cmi typing/env.cmi \
     parsing/asttypes.cmi typing/tast_mapper.cmi
 typing/tast_mapper.cmx : typing/typedtree.cmx typing/env.cmx \
     parsing/asttypes.cmi typing/tast_mapper.cmi
+typing/tast_mapper.cmi : typing/typedtree.cmi typing/env.cmi \
+    parsing/asttypes.cmi
 typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \
     typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
     typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \
@@ -371,42 +350,54 @@ typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \
     typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \
     parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \
     parsing/ast_helper.cmx typing/typeclass.cmi
+typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
 typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \
-    typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \
-    typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
-    typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \
-    typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
-    parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
-    typing/cmt_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
-    typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
-    typing/annot.cmi typing/typecore.cmi
+    typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
+    typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \
+    typing/primitive.cmi typing/predef.cmi typing/path.cmi \
+    parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \
+    utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \
+    utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \
+    parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \
+    typing/typecore.cmi
 typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \
-    typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \
-    typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
-    typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \
-    typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
-    parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
-    typing/cmt_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
-    typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
-    typing/annot.cmi typing/typecore.cmi
+    typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
+    typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \
+    typing/primitive.cmx typing/predef.cmx typing/path.cmx \
+    parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \
+    utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
+    typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \
+    utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \
+    parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \
+    typing/typecore.cmi
+typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi
 typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \
     typing/types.cmi typing/typedtree.cmi typing/subst.cmi \
     typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
     typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/attr_helper.cmi \
-    parsing/asttypes.cmi parsing/ast_iterator.cmi parsing/ast_helper.cmi \
-    typing/typedecl.cmi
+    typing/ident.cmi typing/env.cmi typing/datarepr.cmi typing/ctype.cmi \
+    utils/config.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
+    typing/btype.cmi parsing/attr_helper.cmi parsing/asttypes.cmi \
+    parsing/ast_iterator.cmi parsing/ast_helper.cmi typing/typedecl.cmi
 typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \
     typing/types.cmx typing/typedtree.cmx typing/subst.cmx \
     typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
     typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \
-    typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/attr_helper.cmx \
-    parsing/asttypes.cmi parsing/ast_iterator.cmx parsing/ast_helper.cmx \
-    typing/typedecl.cmi
+    typing/ident.cmx typing/env.cmx typing/datarepr.cmx typing/ctype.cmx \
+    utils/config.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
+    typing/btype.cmx parsing/attr_helper.cmx parsing/asttypes.cmi \
+    parsing/ast_iterator.cmx parsing/ast_helper.cmx typing/typedecl.cmi
+typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/includecore.cmi typing/ident.cmi typing/env.cmi \
+    parsing/asttypes.cmi
 typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
     parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \
@@ -415,14 +406,19 @@ typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
     parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \
     typing/typedtree.cmi
+typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
 typing/typedtreeIter.cmo : typing/typedtree.cmi utils/misc.cmi \
     parsing/asttypes.cmi typing/typedtreeIter.cmi
 typing/typedtreeIter.cmx : typing/typedtree.cmx utils/misc.cmx \
     parsing/asttypes.cmi typing/typedtreeIter.cmi
+typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi
 typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \
     typing/typedtreeMap.cmi
 typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \
     typing/typedtreeMap.cmi
+typing/typedtreeMap.cmi : typing/typedtree.cmi
 typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
     typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
     typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \
@@ -443,12 +439,19 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
     utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \
     parsing/asttypes.cmi parsing/ast_iterator.cmx typing/annot.cmi \
     typing/typemod.cmi
+typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
+    parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/includemod.cmi typing/ident.cmi \
+    typing/env.cmi parsing/asttypes.cmi
 typing/types.cmo : typing/primitive.cmi typing/path.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi parsing/asttypes.cmi typing/types.cmi
 typing/types.cmx : typing/primitive.cmx typing/path.cmx \
     parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \
     typing/ident.cmx parsing/asttypes.cmi typing/types.cmi
+typing/types.cmi : typing/primitive.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi parsing/asttypes.cmi
 typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \
     typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/predef.cmi \
     typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
@@ -463,6 +466,9 @@ typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \
     typing/ctype.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
     typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
     typing/typetexp.cmi
+typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/env.cmi parsing/asttypes.cmi
 typing/untypeast.cmo : typing/typedtree.cmi typing/path.cmi \
     parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \
@@ -471,41 +477,9 @@ typing/untypeast.cmx : typing/typedtree.cmx typing/path.cmx \
     parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \
     parsing/ast_helper.cmx typing/untypeast.cmi
-bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi
-bytecomp/bytelibrarian.cmi :
-bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi
-bytecomp/bytepackager.cmi : typing/ident.cmi typing/env.cmi
-bytecomp/bytesections.cmi :
-bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi
-bytecomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
-bytecomp/dll.cmi :
-bytecomp/emitcode.cmi : bytecomp/instruct.cmi bytecomp/cmo_format.cmi
-bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \
-    parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
-bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
-    parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
-bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \
-    bytecomp/lambda.cmi typing/ident.cmi
-bytecomp/meta.cmi : bytecomp/instruct.cmi
-bytecomp/printinstr.cmi : bytecomp/instruct.cmi
-bytecomp/printlambda.cmi : bytecomp/lambda.cmi
-bytecomp/runtimedef.cmi :
-bytecomp/simplif.cmi : bytecomp/lambda.cmi typing/ident.cmi
-bytecomp/switch.cmi :
-bytecomp/symtable.cmi : utils/misc.cmi typing/ident.cmi \
-    bytecomp/cmo_format.cmi
-bytecomp/translattribute.cmi : typing/typedtree.cmi parsing/parsetree.cmi \
-    parsing/location.cmi bytecomp/lambda.cmi
-bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \
-    bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
-bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \
-    typing/primitive.cmi typing/path.cmi parsing/location.cmi \
-    bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
-bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \
-    parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi
-bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
-bytecomp/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
-    bytecomp/lambda.cmi typing/env.cmi
+typing/untypeast.cmi : typing/typedtree.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+    parsing/asttypes.cmi
 bytecomp/bytegen.cmo : typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \
     typing/primitive.cmi utils/misc.cmi bytecomp/matching.cmi \
     bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \
@@ -514,24 +488,27 @@ bytecomp/bytegen.cmx : typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
     typing/primitive.cmx utils/misc.cmx bytecomp/matching.cmx \
     bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \
     utils/config.cmx parsing/asttypes.cmi bytecomp/bytegen.cmi
+bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi
 bytecomp/bytelibrarian.cmo : utils/misc.cmi parsing/location.cmi \
     utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \
     bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi
 bytecomp/bytelibrarian.cmx : utils/misc.cmx parsing/location.cmx \
     utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \
     bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi
+bytecomp/bytelibrarian.cmi :
 bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \
     bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \
-    bytecomp/lambda.cmi bytecomp/instruct.cmi bytecomp/dll.cmi \
-    utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \
-    utils/clflags.cmi utils/ccomp.cmi bytecomp/bytesections.cmi \
-    bytecomp/bytelink.cmi
+    bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \
+    bytecomp/dll.cmi utils/consistbl.cmi utils/config.cmi \
+    bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \
+    bytecomp/bytesections.cmi bytecomp/bytelink.cmi
 bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \
     bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \
-    bytecomp/lambda.cmx bytecomp/instruct.cmx bytecomp/dll.cmx \
-    utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \
-    utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \
-    bytecomp/bytelink.cmi
+    bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \
+    bytecomp/dll.cmx utils/consistbl.cmx utils/config.cmx \
+    bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \
+    bytecomp/bytesections.cmx bytecomp/bytelink.cmi
+bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi
 bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
     typing/subst.cmi bytecomp/printlambda.cmi typing/path.cmi utils/misc.cmi \
     parsing/location.cmi bytecomp/instruct.cmi typing/ident.cmi \
@@ -544,36 +521,44 @@ bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
     typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \
     bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \
     bytecomp/bytegen.cmx bytecomp/bytepackager.cmi
+bytecomp/bytepackager.cmi : typing/ident.cmi typing/env.cmi
 bytecomp/bytesections.cmo : utils/config.cmi bytecomp/bytesections.cmi
 bytecomp/bytesections.cmx : utils/config.cmx bytecomp/bytesections.cmi
-bytecomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \
-    bytecomp/debuginfo.cmi
-bytecomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
-    bytecomp/debuginfo.cmi
+bytecomp/bytesections.cmi :
+bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi
 bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi
 bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi
+bytecomp/dll.cmi :
 bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \
     bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \
     parsing/location.cmi bytecomp/lambda.cmi bytecomp/instruct.cmi \
-    typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \
-    typing/btype.cmi parsing/asttypes.cmi bytecomp/emitcode.cmi
+    typing/ident.cmi typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi \
+    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+    bytecomp/emitcode.cmi
 bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \
     bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \
     parsing/location.cmx bytecomp/lambda.cmx bytecomp/instruct.cmx \
-    typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \
-    typing/btype.cmx parsing/asttypes.cmi bytecomp/emitcode.cmi
+    typing/ident.cmx typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi \
+    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+    bytecomp/emitcode.cmi
+bytecomp/emitcode.cmi : bytecomp/instruct.cmi typing/ident.cmi \
+    bytecomp/cmo_format.cmi
 bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
     bytecomp/instruct.cmi
 bytecomp/instruct.cmx : typing/types.cmx typing/subst.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
     bytecomp/instruct.cmi
+bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \
+    parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
 bytecomp/lambda.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
     utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
     parsing/asttypes.cmi bytecomp/lambda.cmi
 bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
     utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
     parsing/asttypes.cmi bytecomp/lambda.cmi
+bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
+    parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
 bytecomp/matching.cmo : typing/types.cmi bytecomp/typeopt.cmi \
     typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi \
@@ -588,8 +573,11 @@ bytecomp/matching.cmx : typing/types.cmx bytecomp/typeopt.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
     utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
     bytecomp/matching.cmi
+bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \
+    bytecomp/lambda.cmi typing/ident.cmi
 bytecomp/meta.cmo : bytecomp/instruct.cmi bytecomp/meta.cmi
 bytecomp/meta.cmx : bytecomp/instruct.cmx bytecomp/meta.cmi
+bytecomp/meta.cmi : bytecomp/instruct.cmi
 bytecomp/opcodes.cmo :
 bytecomp/opcodes.cmx :
 bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \
@@ -598,14 +586,17 @@ bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \
 bytecomp/printinstr.cmx : bytecomp/printlambda.cmx parsing/location.cmx \
     bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \
     bytecomp/printinstr.cmi
+bytecomp/printinstr.cmi : bytecomp/instruct.cmi
 bytecomp/printlambda.cmo : typing/types.cmi typing/primitive.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
     parsing/asttypes.cmi bytecomp/printlambda.cmi
 bytecomp/printlambda.cmx : typing/types.cmx typing/primitive.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
     parsing/asttypes.cmi bytecomp/printlambda.cmi
+bytecomp/printlambda.cmi : bytecomp/lambda.cmi
 bytecomp/runtimedef.cmo : bytecomp/runtimedef.cmi
 bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi
+bytecomp/runtimedef.cmi :
 bytecomp/simplif.cmo : utils/warnings.cmi utils/tbl.cmi typing/stypes.cmi \
     utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
     utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \
@@ -614,8 +605,11 @@ bytecomp/simplif.cmx : utils/warnings.cmx utils/tbl.cmx typing/stypes.cmx \
     utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
     utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \
     bytecomp/simplif.cmi
+bytecomp/simplif.cmi : utils/misc.cmi parsing/location.cmi \
+    bytecomp/lambda.cmi typing/ident.cmi
 bytecomp/switch.cmo : bytecomp/switch.cmi
 bytecomp/switch.cmx : bytecomp/switch.cmi
+bytecomp/switch.cmi :
 bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \
     typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi utils/config.cmi \
@@ -626,6 +620,8 @@ bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \
     bytecomp/lambda.cmx typing/ident.cmx bytecomp/dll.cmx utils/config.cmx \
     bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytesections.cmx \
     parsing/asttypes.cmi bytecomp/symtable.cmi
+bytecomp/symtable.cmi : utils/misc.cmi typing/ident.cmi \
+    bytecomp/cmo_format.cmi
 bytecomp/translattribute.cmo : utils/warnings.cmi typing/typedtree.cmi \
     parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi bytecomp/lambda.cmi utils/config.cmi \
@@ -634,6 +630,8 @@ bytecomp/translattribute.cmx : utils/warnings.cmx typing/typedtree.cmx \
     parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx bytecomp/lambda.cmx utils/config.cmx \
     bytecomp/translattribute.cmi
+bytecomp/translattribute.cmi : typing/typedtree.cmi parsing/parsetree.cmi \
+    parsing/location.cmi bytecomp/lambda.cmi
 bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \
     typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \
     typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \
@@ -644,6 +642,8 @@ bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \
     typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \
     bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi
+bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \
+    bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
 bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \
     typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translattribute.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi \
@@ -658,6 +658,9 @@ bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \
     parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
     typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi
+bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \
+    typing/primitive.cmi typing/path.cmi parsing/location.cmi \
+    bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
 bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \
     bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
     bytecomp/translattribute.cmi typing/printtyp.cmi typing/primitive.cmi \
@@ -672,99 +675,32 @@ bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \
     parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
     typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
     parsing/asttypes.cmi bytecomp/translmod.cmi
+bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \
+    parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi
 bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \
-    parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
-    utils/config.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
-    bytecomp/translobj.cmi
+    parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
+    typing/btype.cmi parsing/asttypes.cmi bytecomp/translobj.cmi
 bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \
-    parsing/longident.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
-    utils/config.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
-    bytecomp/translobj.cmi
+    parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \
+    typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
+    typing/btype.cmx parsing/asttypes.cmi bytecomp/translobj.cmi
+bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
 bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
-    typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi typing/ident.cmi \
-    typing/env.cmi typing/ctype.cmi bytecomp/typeopt.cmi
+    typing/typedecl.cmi typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi typing/env.cmi typing/ctype.cmi bytecomp/typeopt.cmi
 bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \
-    typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \
-    typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi
-asmcomp/CSEgen.cmi : asmcomp/mach.cmi
-asmcomp/asmgen.cmi : utils/timings.cmi bytecomp/lambda.cmi \
-    middle_end/flambda.cmi asmcomp/cmm.cmi middle_end/backend_intf.cmi
-asmcomp/asmlibrarian.cmi :
-asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi
-asmcomp/asmpackager.cmi : typing/env.cmi middle_end/backend_intf.cmi
-asmcomp/branch_relaxation.cmi : asmcomp/linearize.cmi \
-    asmcomp/branch_relaxation_intf.cmo
-asmcomp/build_export_info.cmi : middle_end/flambda.cmi \
-    asmcomp/export_info.cmi middle_end/backend_intf.cmi
-asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \
-    bytecomp/debuginfo.cmi parsing/asttypes.cmi
-asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
-asmcomp/closure_offsets.cmi : middle_end/base_types/var_within_closure.cmi \
-    middle_end/flambda.cmi middle_end/base_types/closure_id.cmi
-asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi \
-    bytecomp/debuginfo.cmi
-asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
-    asmcomp/clambda.cmi
-asmcomp/cmx_format.cmi : asmcomp/export_info.cmi asmcomp/clambda.cmi
-asmcomp/coloring.cmi :
-asmcomp/comballoc.cmi : asmcomp/mach.cmi
-asmcomp/compilenv.cmi : utils/timings.cmi middle_end/base_types/symbol.cmi \
-    middle_end/base_types/set_of_closures_id.cmi \
-    middle_end/base_types/linkage_name.cmi typing/ident.cmi \
-    middle_end/flambda.cmi asmcomp/export_info.cmi \
-    middle_end/base_types/compilation_unit.cmi asmcomp/cmx_format.cmi \
-    middle_end/base_types/closure_id.cmi asmcomp/clambda.cmi
-asmcomp/deadcode.cmi : asmcomp/mach.cmi
-asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
-asmcomp/emitaux.cmi : bytecomp/debuginfo.cmi
-asmcomp/export_info.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/var_within_closure.cmi \
-    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
-    middle_end/simple_value_approx.cmi \
-    middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \
-    middle_end/base_types/export_id.cmi \
-    middle_end/base_types/compilation_unit.cmi \
-    middle_end/base_types/closure_id.cmi
-asmcomp/export_info_for_pack.cmi : asmcomp/export_info.cmi \
-    middle_end/base_types/compilation_unit.cmi
-asmcomp/flambda_to_clambda.cmi : middle_end/base_types/symbol.cmi \
-    middle_end/flambda.cmi asmcomp/export_info.cmi asmcomp/clambda.cmi
-asmcomp/import_approx.cmi : middle_end/base_types/symbol.cmi \
-    middle_end/simple_value_approx.cmi
-asmcomp/interf.cmi : asmcomp/mach.cmi
-asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
-    bytecomp/debuginfo.cmi
-asmcomp/liveness.cmi : asmcomp/mach.cmi
-asmcomp/mach.cmi : asmcomp/reg.cmi bytecomp/lambda.cmi \
-    bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
-asmcomp/printclambda.cmi : asmcomp/clambda.cmi
-asmcomp/printcmm.cmi : asmcomp/cmm.cmi
-asmcomp/printlinear.cmi : asmcomp/linearize.cmi
-asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
-asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
-asmcomp/reg.cmi : typing/ident.cmi asmcomp/cmm.cmi
-asmcomp/reload.cmi : asmcomp/mach.cmi
-asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
-asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi
-asmcomp/scheduling.cmi : asmcomp/linearize.cmi
-asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
-    typing/ident.cmi bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
-asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi
-asmcomp/spill.cmi : asmcomp/mach.cmi
-asmcomp/split.cmi : asmcomp/mach.cmi
-asmcomp/strmatch.cmi : asmcomp/cmm.cmi
-asmcomp/un_anf.cmi : asmcomp/clambda.cmi
-asmcomp/x86_ast.cmi :
-asmcomp/x86_dsl.cmi : asmcomp/x86_ast.cmi
-asmcomp/x86_gas.cmi : asmcomp/x86_ast.cmi
-asmcomp/x86_masm.cmi : asmcomp/x86_ast.cmi
-asmcomp/x86_proc.cmi : asmcomp/x86_ast.cmi
+    typing/typedecl.cmx typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx \
+    typing/ident.cmx typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi
+bytecomp/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
+    bytecomp/lambda.cmi typing/env.cmi
 asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo
 asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx
 asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
     asmcomp/cmm.cmi asmcomp/CSEgen.cmi
 asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
     asmcomp/cmm.cmx asmcomp/CSEgen.cmi
+asmcomp/CSEgen.cmi : asmcomp/mach.cmi
 asmcomp/arch.cmo : utils/clflags.cmi
 asmcomp/arch.cmx : utils/clflags.cmx
 asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \
@@ -775,12 +711,12 @@ asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \
     typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \
     asmcomp/liveness.cmi middle_end/base_types/linkage_name.cmi \
     asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/interf.cmi \
-    asmcomp/flambda_to_clambda.cmi middle_end/flambda.cmi asmcomp/emitaux.cmi \
-    asmcomp/emit.cmi asmcomp/deadcode.cmi utils/config.cmi \
-    asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \
-    asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \
-    asmcomp/clambda.cmi asmcomp/CSE.cmo asmcomp/build_export_info.cmi \
-    asmcomp/asmgen.cmi
+    typing/ident.cmi asmcomp/flambda_to_clambda.cmi middle_end/flambda.cmi \
+    asmcomp/emitaux.cmi asmcomp/emit.cmi asmcomp/deadcode.cmi \
+    utils/config.cmi asmcomp/compilenv.cmi asmcomp/comballoc.cmi \
+    asmcomp/coloring.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \
+    asmcomp/closure.cmi utils/clflags.cmi asmcomp/clambda.cmi asmcomp/CSE.cmo \
+    asmcomp/build_export_info.cmi asmcomp/asmgen.cmi
 asmcomp/asmgen.cmx : asmcomp/un_anf.cmx bytecomp/translmod.cmx \
     utils/timings.cmx middle_end/base_types/symbol.cmx asmcomp/split.cmx \
     asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \
@@ -789,12 +725,14 @@ asmcomp/asmgen.cmx : asmcomp/un_anf.cmx bytecomp/translmod.cmx \
     typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \
     asmcomp/liveness.cmx middle_end/base_types/linkage_name.cmx \
     asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/interf.cmx \
-    asmcomp/flambda_to_clambda.cmx middle_end/flambda.cmx asmcomp/emitaux.cmx \
-    asmcomp/emit.cmx asmcomp/deadcode.cmx utils/config.cmx \
-    asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \
-    asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \
-    asmcomp/clambda.cmx asmcomp/CSE.cmx asmcomp/build_export_info.cmx \
-    asmcomp/asmgen.cmi
+    typing/ident.cmx asmcomp/flambda_to_clambda.cmx middle_end/flambda.cmx \
+    asmcomp/emitaux.cmx asmcomp/emit.cmx asmcomp/deadcode.cmx \
+    utils/config.cmx asmcomp/compilenv.cmx asmcomp/comballoc.cmx \
+    asmcomp/coloring.cmx asmcomp/cmmgen.cmx asmcomp/cmm.cmx \
+    asmcomp/closure.cmx utils/clflags.cmx asmcomp/clambda.cmx asmcomp/CSE.cmx \
+    asmcomp/build_export_info.cmx asmcomp/asmgen.cmi
+asmcomp/asmgen.cmi : utils/timings.cmi bytecomp/lambda.cmi typing/ident.cmi \
+    middle_end/flambda.cmi asmcomp/cmm.cmi middle_end/backend_intf.cmi
 asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \
     asmcomp/export_info.cmi utils/config.cmi asmcomp/compilenv.cmi \
     asmcomp/cmx_format.cmi utils/clflags.cmi asmcomp/clambda.cmi \
@@ -803,6 +741,7 @@ asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \
     asmcomp/export_info.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \
     utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmi
+asmcomp/asmlibrarian.cmi :
 asmcomp/asmlink.cmo : utils/timings.cmi bytecomp/runtimedef.cmi \
     utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \
     utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \
@@ -813,6 +752,7 @@ asmcomp/asmlink.cmx : utils/timings.cmx bytecomp/runtimedef.cmx \
     utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \
     utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi
+asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi
 asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
     utils/timings.cmi utils/misc.cmi middle_end/middle_end.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
@@ -829,14 +769,19 @@ asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
     middle_end/base_types/compilation_unit.cmx asmcomp/cmx_format.cmi \
     utils/clflags.cmx utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
     asmcomp/asmpackager.cmi
+asmcomp/asmpackager.cmi : typing/env.cmi middle_end/backend_intf.cmi
 asmcomp/branch_relaxation.cmo : utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/branch_relaxation_intf.cmo \
     asmcomp/branch_relaxation.cmi
 asmcomp/branch_relaxation.cmx : utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/branch_relaxation_intf.cmx \
     asmcomp/branch_relaxation.cmi
-asmcomp/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/arch.cmo
-asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/arch.cmx
+asmcomp/branch_relaxation.cmi : asmcomp/linearize.cmi \
+    asmcomp/branch_relaxation_intf.cmo
+asmcomp/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/cmm.cmi \
+    asmcomp/arch.cmo
+asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/cmm.cmx \
+    asmcomp/arch.cmx
 asmcomp/build_export_info.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
@@ -857,22 +802,27 @@ asmcomp/build_export_info.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     middle_end/backend_intf.cmi middle_end/allocated_const.cmx \
     asmcomp/build_export_info.cmi
+asmcomp/build_export_info.cmi : middle_end/flambda.cmi \
+    asmcomp/export_info.cmi middle_end/backend_intf.cmi
 asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \
-    bytecomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
+    middle_end/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
 asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \
-    bytecomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
+    middle_end/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
+asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \
+    middle_end/debuginfo.cmi parsing/asttypes.cmi
 asmcomp/closure.cmo : utils/warnings.cmi utils/tbl.cmi bytecomp/switch.cmi \
     bytecomp/simplif.cmi typing/primitive.cmi utils/misc.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
-    bytecomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
-    asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
-    asmcomp/closure.cmi
+    middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
+    utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
+    asmcomp/arch.cmo asmcomp/closure.cmi
 asmcomp/closure.cmx : utils/warnings.cmx utils/tbl.cmx bytecomp/switch.cmx \
     bytecomp/simplif.cmx typing/primitive.cmx utils/misc.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
-    bytecomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
-    asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
-    asmcomp/closure.cmi
+    middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
+    utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
+    asmcomp/arch.cmx asmcomp/closure.cmi
+asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
 asmcomp/closure_offsets.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi utils/misc.cmi \
     middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
@@ -883,30 +833,39 @@ asmcomp/closure_offsets.cmx : middle_end/base_types/variable.cmx \
     middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
     middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \
     asmcomp/closure_offsets.cmi
+asmcomp/closure_offsets.cmi : middle_end/base_types/var_within_closure.cmi \
+    middle_end/flambda.cmi middle_end/base_types/closure_id.cmi
 asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \
-    bytecomp/debuginfo.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
+    middle_end/debuginfo.cmi asmcomp/arch.cmo asmcomp/cmm.cmi
 asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \
-    bytecomp/debuginfo.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
+    middle_end/debuginfo.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
+asmcomp/cmm.cmi : bytecomp/lambda.cmi typing/ident.cmi \
+    middle_end/debuginfo.cmi
 asmcomp/cmmgen.cmo : asmcomp/un_anf.cmi typing/types.cmi bytecomp/switch.cmi \
     asmcomp/strmatch.cmi asmcomp/proc.cmi bytecomp/printlambda.cmi \
     typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
-    bytecomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
+    middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
     asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \
     asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
     asmcomp/cmmgen.cmi
 asmcomp/cmmgen.cmx : asmcomp/un_anf.cmx typing/types.cmx bytecomp/switch.cmx \
     asmcomp/strmatch.cmx asmcomp/proc.cmx bytecomp/printlambda.cmx \
     typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
-    bytecomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
+    middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
     asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
     asmcomp/cmmgen.cmi
+asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
+    asmcomp/clambda.cmi
+asmcomp/cmx_format.cmi : asmcomp/export_info.cmi asmcomp/clambda.cmi
 asmcomp/coloring.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi
 asmcomp/coloring.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi
+asmcomp/coloring.cmi :
 asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \
     asmcomp/arch.cmo asmcomp/comballoc.cmi
 asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \
     asmcomp/arch.cmx asmcomp/comballoc.cmi
+asmcomp/comballoc.cmi : asmcomp/mach.cmi
 asmcomp/compilenv.cmo : utils/warnings.cmi middle_end/base_types/symbol.cmi \
     middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \
     parsing/location.cmi middle_end/base_types/linkage_name.cmi \
@@ -923,28 +882,35 @@ asmcomp/compilenv.cmx : utils/warnings.cmx middle_end/base_types/symbol.cmx \
     middle_end/base_types/compilation_unit.cmx asmcomp/cmx_format.cmi \
     middle_end/base_types/closure_id.cmx asmcomp/clambda.cmx \
     asmcomp/compilenv.cmi
+asmcomp/compilenv.cmi : utils/timings.cmi middle_end/base_types/symbol.cmi \
+    middle_end/base_types/set_of_closures_id.cmi \
+    middle_end/base_types/linkage_name.cmi typing/ident.cmi \
+    middle_end/flambda.cmi asmcomp/export_info.cmi \
+    middle_end/base_types/compilation_unit.cmi asmcomp/cmx_format.cmi \
+    middle_end/base_types/closure_id.cmi asmcomp/clambda.cmi
 asmcomp/deadcode.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
-    asmcomp/deadcode.cmi
+    utils/config.cmi asmcomp/deadcode.cmi
 asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
-    asmcomp/deadcode.cmi
+    utils/config.cmx asmcomp/deadcode.cmi
+asmcomp/deadcode.cmi : asmcomp/mach.cmi
 asmcomp/emit.cmo : asmcomp/x86_proc.cmi asmcomp/x86_masm.cmi \
     asmcomp/x86_gas.cmi asmcomp/x86_dsl.cmi asmcomp/x86_ast.cmi \
     asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi \
-    asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/emitaux.cmi \
-    bytecomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
-    asmcomp/cmm.cmi utils/clflags.cmi asmcomp/branch_relaxation.cmi \
-    asmcomp/arch.cmo asmcomp/emit.cmi
+    asmcomp/linearize.cmi asmcomp/emitaux.cmi middle_end/debuginfo.cmi \
+    utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \
+    asmcomp/branch_relaxation.cmi asmcomp/arch.cmo asmcomp/emit.cmi
 asmcomp/emit.cmx : asmcomp/x86_proc.cmx asmcomp/x86_masm.cmx \
     asmcomp/x86_gas.cmx asmcomp/x86_dsl.cmx asmcomp/x86_ast.cmi \
     asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx \
-    asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/emitaux.cmx \
-    bytecomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
-    asmcomp/cmm.cmx utils/clflags.cmx asmcomp/branch_relaxation.cmx \
-    asmcomp/arch.cmx asmcomp/emit.cmi
-asmcomp/emitaux.cmo : asmcomp/linearize.cmi bytecomp/debuginfo.cmi \
-    utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx : asmcomp/linearize.cmx bytecomp/debuginfo.cmx \
-    utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
+    asmcomp/linearize.cmx asmcomp/emitaux.cmx middle_end/debuginfo.cmx \
+    utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx \
+    asmcomp/branch_relaxation.cmx asmcomp/arch.cmx asmcomp/emit.cmi
+asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
+asmcomp/emitaux.cmo : middle_end/debuginfo.cmi utils/config.cmi \
+    asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
+asmcomp/emitaux.cmx : middle_end/debuginfo.cmx utils/config.cmx \
+    asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
+asmcomp/emitaux.cmi : middle_end/debuginfo.cmi
 asmcomp/export_info.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
@@ -961,6 +927,14 @@ asmcomp/export_info.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/export_id.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx asmcomp/export_info.cmi
+asmcomp/export_info.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/var_within_closure.cmi \
+    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
+    middle_end/simple_value_approx.cmi \
+    middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \
+    middle_end/base_types/export_id.cmi \
+    middle_end/base_types/compilation_unit.cmi \
+    middle_end/base_types/closure_id.cmi
 asmcomp/export_info_for_pack.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/symbol.cmi \
@@ -979,6 +953,8 @@ asmcomp/export_info_for_pack.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/export_id.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx asmcomp/export_info_for_pack.cmi
+asmcomp/export_info_for_pack.cmi : asmcomp/export_info.cmi \
+    middle_end/base_types/compilation_unit.cmi
 asmcomp/flambda_to_clambda.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
@@ -987,7 +963,7 @@ asmcomp/flambda_to_clambda.cmo : middle_end/base_types/variable.cmi \
     utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
     utils/misc.cmi middle_end/base_types/linkage_name.cmi typing/ident.cmi \
     middle_end/flambda_utils.cmi middle_end/flambda.cmi \
-    asmcomp/export_info.cmi bytecomp/debuginfo.cmi asmcomp/compilenv.cmi \
+    asmcomp/export_info.cmi middle_end/debuginfo.cmi asmcomp/compilenv.cmi \
     asmcomp/closure_offsets.cmi middle_end/base_types/closure_id.cmi \
     utils/clflags.cmi asmcomp/clambda.cmi middle_end/allocated_const.cmi \
     asmcomp/flambda_to_clambda.cmi
@@ -999,10 +975,12 @@ asmcomp/flambda_to_clambda.cmx : middle_end/base_types/variable.cmx \
     utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \
     utils/misc.cmx middle_end/base_types/linkage_name.cmx typing/ident.cmx \
     middle_end/flambda_utils.cmx middle_end/flambda.cmx \
-    asmcomp/export_info.cmx bytecomp/debuginfo.cmx asmcomp/compilenv.cmx \
+    asmcomp/export_info.cmx middle_end/debuginfo.cmx asmcomp/compilenv.cmx \
     asmcomp/closure_offsets.cmx middle_end/base_types/closure_id.cmx \
     utils/clflags.cmx asmcomp/clambda.cmx middle_end/allocated_const.cmx \
     asmcomp/flambda_to_clambda.cmi
+asmcomp/flambda_to_clambda.cmi : middle_end/base_types/symbol.cmi \
+    middle_end/flambda.cmi asmcomp/export_info.cmi asmcomp/clambda.cmi
 asmcomp/import_approx.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/symbol.cmi middle_end/simple_value_approx.cmi \
@@ -1019,254 +997,162 @@ asmcomp/import_approx.cmx : middle_end/base_types/variable.cmx \
     middle_end/flambda.cmx asmcomp/export_info.cmx \
     middle_end/base_types/export_id.cmx asmcomp/compilenv.cmx \
     middle_end/base_types/closure_id.cmx asmcomp/import_approx.cmi
+asmcomp/import_approx.cmi : middle_end/base_types/symbol.cmi \
+    middle_end/simple_value_approx.cmi
 asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
     asmcomp/interf.cmi
 asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
     asmcomp/interf.cmi
+asmcomp/interf.cmi : asmcomp/mach.cmi
 asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
-    asmcomp/mach.cmi bytecomp/lambda.cmi bytecomp/debuginfo.cmi \
+    asmcomp/mach.cmi middle_end/debuginfo.cmi utils/config.cmi \
     asmcomp/cmm.cmi asmcomp/linearize.cmi
 asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
-    asmcomp/mach.cmx bytecomp/lambda.cmx bytecomp/debuginfo.cmx \
+    asmcomp/mach.cmx middle_end/debuginfo.cmx utils/config.cmx \
     asmcomp/cmm.cmx asmcomp/linearize.cmi
+asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \
+    middle_end/debuginfo.cmi asmcomp/cmm.cmi
 asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
-    asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \
+    asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi utils/config.cmi \
     asmcomp/liveness.cmi
 asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
-    asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx \
+    asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx utils/config.cmx \
     asmcomp/liveness.cmi
-asmcomp/mach.cmo : asmcomp/reg.cmi bytecomp/lambda.cmi \
-    bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/mach.cmi
-asmcomp/mach.cmx : asmcomp/reg.cmx bytecomp/lambda.cmx \
-    bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/mach.cmi
+asmcomp/liveness.cmi : asmcomp/mach.cmi
+asmcomp/mach.cmo : asmcomp/reg.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \
+    asmcomp/arch.cmo asmcomp/mach.cmi
+asmcomp/mach.cmx : asmcomp/reg.cmx middle_end/debuginfo.cmx asmcomp/cmm.cmx \
+    asmcomp/arch.cmx asmcomp/mach.cmi
+asmcomp/mach.cmi : asmcomp/reg.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \
+    asmcomp/arch.cmo
 asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \
     typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
     asmcomp/printclambda.cmi
 asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \
     typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \
     asmcomp/printclambda.cmi
+asmcomp/printclambda.cmi : asmcomp/clambda.cmi
 asmcomp/printcmm.cmo : bytecomp/lambda.cmi typing/ident.cmi \
-    bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi
+    middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi
 asmcomp/printcmm.cmx : bytecomp/lambda.cmx typing/ident.cmx \
-    bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi
-asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/mach.cmi \
-    asmcomp/linearize.cmi bytecomp/lambda.cmi bytecomp/debuginfo.cmi \
+    middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmi
+asmcomp/printcmm.cmi : asmcomp/cmm.cmi
+asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/printcmm.cmi \
+    asmcomp/mach.cmi asmcomp/linearize.cmi middle_end/debuginfo.cmi \
     asmcomp/printlinear.cmi
-asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/mach.cmx \
-    asmcomp/linearize.cmx bytecomp/lambda.cmx bytecomp/debuginfo.cmx \
+asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/printcmm.cmx \
+    asmcomp/mach.cmx asmcomp/linearize.cmx middle_end/debuginfo.cmx \
     asmcomp/printlinear.cmi
+asmcomp/printlinear.cmi : asmcomp/linearize.cmi
 asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
-    asmcomp/printcmm.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
-    bytecomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
-    asmcomp/printmach.cmi
+    asmcomp/printcmm.cmi asmcomp/mach.cmi middle_end/debuginfo.cmi \
+    utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi
 asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
-    asmcomp/printcmm.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \
-    bytecomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
-    asmcomp/printmach.cmi
+    asmcomp/printcmm.cmx asmcomp/mach.cmx middle_end/debuginfo.cmx \
+    utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi
+asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
 asmcomp/proc.cmo : asmcomp/x86_proc.cmi asmcomp/reg.cmi utils/misc.cmi \
     asmcomp/mach.cmi utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
     asmcomp/proc.cmi
 asmcomp/proc.cmx : asmcomp/x86_proc.cmx asmcomp/reg.cmx utils/misc.cmx \
     asmcomp/mach.cmx utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
     asmcomp/proc.cmi
+asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
 asmcomp/reg.cmo : typing/ident.cmi asmcomp/cmm.cmi asmcomp/reg.cmi
 asmcomp/reg.cmx : typing/ident.cmx asmcomp/cmm.cmx asmcomp/reg.cmi
+asmcomp/reg.cmi : typing/ident.cmi asmcomp/cmm.cmi
 asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
     asmcomp/cmm.cmi utils/clflags.cmi asmcomp/reload.cmi
 asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
     asmcomp/cmm.cmx utils/clflags.cmx asmcomp/reload.cmi
+asmcomp/reload.cmi : asmcomp/mach.cmi
 asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/reloadgen.cmi
 asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/reloadgen.cmi
+asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
 asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
     asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
     asmcomp/schedgen.cmi
 asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
     asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
     asmcomp/schedgen.cmi
+asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi
 asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi
 asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi
+asmcomp/scheduling.cmi : asmcomp/linearize.cmi
 asmcomp/selectgen.cmo : utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \
     asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
-    typing/ident.cmi bytecomp/debuginfo.cmi asmcomp/cmm.cmi utils/clflags.cmi \
-    asmcomp/arch.cmo asmcomp/selectgen.cmi
+    typing/ident.cmi middle_end/debuginfo.cmi utils/config.cmi \
+    asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi
 asmcomp/selectgen.cmx : utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \
     asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \
-    typing/ident.cmx bytecomp/debuginfo.cmx asmcomp/cmm.cmx utils/clflags.cmx \
-    asmcomp/arch.cmx asmcomp/selectgen.cmi
-asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/proc.cmi \
-    asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \
-    asmcomp/selection.cmi
-asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \
-    asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \
-    asmcomp/selection.cmi
+    typing/ident.cmx middle_end/debuginfo.cmx utils/config.cmx \
+    asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi
+asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
+    typing/ident.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \
+    asmcomp/arch.cmo
+asmcomp/selection.cmo : asmcomp/spacetime_profiling.cmi asmcomp/proc.cmi \
+    asmcomp/mach.cmi utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi \
+    asmcomp/arch.cmo asmcomp/selection.cmi
+asmcomp/selection.cmx : asmcomp/spacetime_profiling.cmx asmcomp/proc.cmx \
+    asmcomp/mach.cmx utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx \
+    asmcomp/arch.cmx asmcomp/selection.cmi
+asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi
+asmcomp/spacetime_profiling.cmo : utils/tbl.cmi asmcomp/selectgen.cmi \
+    asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi middle_end/debuginfo.cmi utils/config.cmi \
+    asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/spacetime_profiling.cmi
+asmcomp/spacetime_profiling.cmx : utils/tbl.cmx asmcomp/selectgen.cmx \
+    asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \
+    typing/ident.cmx middle_end/debuginfo.cmx utils/config.cmx \
+    asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/spacetime_profiling.cmi
+asmcomp/spacetime_profiling.cmi : asmcomp/selectgen.cmi
 asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi asmcomp/spill.cmi
 asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
     asmcomp/mach.cmx asmcomp/spill.cmi
+asmcomp/spill.cmi : asmcomp/mach.cmi
 asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/split.cmi
 asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/split.cmi
+asmcomp/split.cmi : asmcomp/mach.cmi
 asmcomp/strmatch.cmo : bytecomp/lambda.cmi typing/ident.cmi asmcomp/cmm.cmi \
     asmcomp/arch.cmo asmcomp/strmatch.cmi
 asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/cmm.cmx \
     asmcomp/arch.cmx asmcomp/strmatch.cmi
+asmcomp/strmatch.cmi : asmcomp/cmm.cmi
 asmcomp/un_anf.cmo : middle_end/semantics_of_primitives.cmi \
     asmcomp/printclambda.cmi utils/misc.cmi bytecomp/lambda.cmi \
-    typing/ident.cmi bytecomp/debuginfo.cmi utils/clflags.cmi \
+    typing/ident.cmi middle_end/debuginfo.cmi utils/clflags.cmi \
     asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/un_anf.cmi
 asmcomp/un_anf.cmx : middle_end/semantics_of_primitives.cmx \
     asmcomp/printclambda.cmx utils/misc.cmx bytecomp/lambda.cmx \
-    typing/ident.cmx bytecomp/debuginfo.cmx utils/clflags.cmx \
+    typing/ident.cmx middle_end/debuginfo.cmx utils/clflags.cmx \
     asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/un_anf.cmi
+asmcomp/un_anf.cmi : asmcomp/clambda.cmi
+asmcomp/x86_ast.cmi :
 asmcomp/x86_dsl.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \
     asmcomp/x86_dsl.cmi
 asmcomp/x86_dsl.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \
     asmcomp/x86_dsl.cmi
+asmcomp/x86_dsl.cmi : asmcomp/x86_ast.cmi
 asmcomp/x86_gas.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \
     utils/misc.cmi asmcomp/x86_gas.cmi
 asmcomp/x86_gas.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \
     utils/misc.cmx asmcomp/x86_gas.cmi
+asmcomp/x86_gas.cmi : asmcomp/x86_ast.cmi
 asmcomp/x86_masm.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \
     asmcomp/x86_masm.cmi
 asmcomp/x86_masm.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \
     asmcomp/x86_masm.cmi
+asmcomp/x86_masm.cmi : asmcomp/x86_ast.cmi
 asmcomp/x86_proc.cmo : asmcomp/x86_ast.cmi utils/config.cmi \
     utils/clflags.cmi utils/ccomp.cmi asmcomp/x86_proc.cmi
 asmcomp/x86_proc.cmx : asmcomp/x86_ast.cmi utils/config.cmx \
     utils/clflags.cmx utils/ccomp.cmx asmcomp/x86_proc.cmi
-middle_end/alias_analysis.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
-    bytecomp/lambda.cmi middle_end/flambda.cmi parsing/asttypes.cmi \
-    middle_end/allocated_const.cmi
-middle_end/allocated_const.cmi :
-middle_end/augment_specialised_args.cmi : middle_end/base_types/variable.cmi \
-    middle_end/projection.cmi middle_end/inlining_cost.cmi \
-    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi
-middle_end/backend_intf.cmi : middle_end/base_types/symbol.cmi \
-    middle_end/simple_value_approx.cmi typing/ident.cmi \
-    middle_end/base_types/closure_id.cmi
-middle_end/closure_conversion.cmi : bytecomp/lambda.cmi typing/ident.cmi \
-    middle_end/flambda.cmi middle_end/backend_intf.cmi
-middle_end/closure_conversion_aux.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/symbol.cmi \
-    middle_end/base_types/static_exception.cmi \
-    middle_end/base_types/mutable_variable.cmi bytecomp/lambda.cmi \
-    typing/ident.cmi
-middle_end/effect_analysis.cmi : middle_end/flambda.cmi
-middle_end/extract_projections.cmi : middle_end/base_types/variable.cmi \
-    middle_end/projection.cmi middle_end/inline_and_simplify_aux.cmi \
-    middle_end/flambda.cmi
-middle_end/find_recursive_functions.cmi : middle_end/base_types/variable.cmi \
-    middle_end/flambda.cmi middle_end/backend_intf.cmi
-middle_end/flambda.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
-    middle_end/base_types/static_exception.cmi \
-    middle_end/base_types/set_of_closures_origin.cmi \
-    middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
-    utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
-    bytecomp/lambda.cmi utils/identifiable.cmi bytecomp/debuginfo.cmi \
-    middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \
-    middle_end/allocated_const.cmi
-middle_end/flambda_invariants.cmi : middle_end/flambda.cmi
-middle_end/flambda_iterators.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/symbol.cmi middle_end/flambda.cmi
-middle_end/flambda_utils.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/var_within_closure.cmi \
-    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
-    bytecomp/switch.cmi middle_end/base_types/static_exception.cmi \
-    middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
-    middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \
-    middle_end/backend_intf.cmi
-middle_end/freshening.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/var_within_closure.cmi \
-    middle_end/base_types/symbol.cmi \
-    middle_end/base_types/static_exception.cmi \
-    middle_end/base_types/mutable_variable.cmi middle_end/flambda.cmi \
-    middle_end/base_types/closure_id.cmi
-middle_end/inconstant_idents.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \
-    middle_end/base_types/compilation_unit.cmi middle_end/backend_intf.cmi
-middle_end/initialize_symbol_to_let_symbol.cmi : middle_end/flambda.cmi
-middle_end/inline_and_simplify.cmi : middle_end/base_types/variable.cmi \
-    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
-    middle_end/backend_intf.cmi
-middle_end/inline_and_simplify_aux.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/symbol.cmi \
-    middle_end/base_types/static_exception.cmi \
-    middle_end/simple_value_approx.cmi \
-    middle_end/base_types/set_of_closures_origin.cmi \
-    middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \
-    middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \
-    middle_end/freshening.cmi middle_end/flambda.cmi bytecomp/debuginfo.cmi \
-    middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi
-middle_end/inlining_cost.cmi : middle_end/projection.cmi \
-    middle_end/flambda.cmi
-middle_end/inlining_decision.cmi : middle_end/base_types/variable.cmi \
-    middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
-    middle_end/inlining_decision_intf.cmi \
-    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
-    bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi
-middle_end/inlining_decision_intf.cmi : middle_end/base_types/variable.cmi \
-    middle_end/simple_value_approx.cmi middle_end/inline_and_simplify_aux.cmi \
-    middle_end/flambda.cmi bytecomp/debuginfo.cmi \
-    middle_end/base_types/closure_id.cmi
-middle_end/inlining_stats.cmi : middle_end/inlining_stats_types.cmi \
-    bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi
-middle_end/inlining_stats_types.cmi : middle_end/inlining_cost.cmi
-middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \
-    middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
-    middle_end/inlining_decision_intf.cmi \
-    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
-    bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi
-middle_end/invariant_params.cmi : middle_end/base_types/variable.cmi \
-    middle_end/flambda.cmi middle_end/backend_intf.cmi
-middle_end/lift_code.cmi : middle_end/base_types/variable.cmi \
-    middle_end/flambda.cmi
-middle_end/lift_constants.cmi : middle_end/flambda.cmi \
-    middle_end/backend_intf.cmi
-middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \
-    middle_end/backend_intf.cmi
-middle_end/middle_end.cmi : utils/timings.cmi bytecomp/lambda.cmi \
-    typing/ident.cmi middle_end/flambda.cmi middle_end/backend_intf.cmi
-middle_end/pass_wrapper.cmi :
-middle_end/projection.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/var_within_closure.cmi utils/identifiable.cmi \
-    middle_end/base_types/closure_id.cmi
-middle_end/ref_to_variables.cmi : middle_end/flambda.cmi
-middle_end/remove_free_vars_equal_to_args.cmi : middle_end/flambda.cmi
-middle_end/remove_unused_arguments.cmi : middle_end/flambda.cmi \
-    middle_end/backend_intf.cmi
-middle_end/remove_unused_closure_vars.cmi : middle_end/flambda.cmi
-middle_end/remove_unused_program_constructs.cmi : middle_end/flambda.cmi
-middle_end/semantics_of_primitives.cmi : bytecomp/lambda.cmi
-middle_end/share_constants.cmi : middle_end/flambda.cmi
-middle_end/simple_value_approx.cmi : middle_end/base_types/variable.cmi \
-    middle_end/base_types/var_within_closure.cmi \
-    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
-    middle_end/freshening.cmi middle_end/flambda.cmi \
-    middle_end/base_types/export_id.cmi middle_end/base_types/closure_id.cmi
-middle_end/simplify_boxed_integer_ops.cmi : \
-    middle_end/simplify_boxed_integer_ops_intf.cmi
-middle_end/simplify_boxed_integer_ops_intf.cmi : \
-    middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
-    middle_end/inlining_cost.cmi middle_end/flambda.cmi
-middle_end/simplify_common.cmi : middle_end/simple_value_approx.cmi \
-    bytecomp/lambda.cmi middle_end/inlining_cost.cmi middle_end/flambda.cmi
-middle_end/simplify_primitives.cmi : middle_end/base_types/variable.cmi \
-    middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
-    middle_end/inlining_cost.cmi middle_end/flambda.cmi \
-    bytecomp/debuginfo.cmi
-middle_end/unbox_closures.cmi : middle_end/base_types/variable.cmi \
-    middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
-    middle_end/flambda.cmi
-middle_end/unbox_free_vars_of_closures.cmi : middle_end/inlining_cost.cmi \
-    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi
-middle_end/unbox_specialised_args.cmi : middle_end/base_types/variable.cmi \
-    middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
-    middle_end/flambda.cmi
+asmcomp/x86_proc.cmi : asmcomp/x86_ast.cmi
 middle_end/alias_analysis.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
@@ -1279,24 +1165,33 @@ middle_end/alias_analysis.cmx : middle_end/base_types/variable.cmx \
     utils/misc.cmx bytecomp/lambda.cmx middle_end/flambda.cmx \
     parsing/asttypes.cmi middle_end/allocated_const.cmx \
     middle_end/alias_analysis.cmi
+middle_end/alias_analysis.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
+    bytecomp/lambda.cmi middle_end/flambda.cmi parsing/asttypes.cmi \
+    middle_end/allocated_const.cmi
 middle_end/allocated_const.cmo : middle_end/allocated_const.cmi
 middle_end/allocated_const.cmx : middle_end/allocated_const.cmi
+middle_end/allocated_const.cmi :
 middle_end/augment_specialised_args.cmo : middle_end/base_types/variable.cmi \
-    middle_end/simple_value_approx.cmi middle_end/projection.cmi \
-    middle_end/pass_wrapper.cmi utils/misc.cmi middle_end/inlining_cost.cmi \
-    middle_end/inline_and_simplify_aux.cmi utils/identifiable.cmi \
-    middle_end/flambda_utils.cmi middle_end/flambda.cmi \
-    bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi \
-    utils/clflags.cmi middle_end/backend_intf.cmi \
-    middle_end/augment_specialised_args.cmi
+    middle_end/projection.cmi middle_end/pass_wrapper.cmi utils/misc.cmi \
+    middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
+    utils/identifiable.cmi middle_end/flambda_utils.cmi \
+    middle_end/flambda.cmi middle_end/debuginfo.cmi \
+    middle_end/base_types/closure_id.cmi utils/clflags.cmi \
+    middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi
 middle_end/augment_specialised_args.cmx : middle_end/base_types/variable.cmx \
-    middle_end/simple_value_approx.cmx middle_end/projection.cmx \
-    middle_end/pass_wrapper.cmx utils/misc.cmx middle_end/inlining_cost.cmx \
-    middle_end/inline_and_simplify_aux.cmx utils/identifiable.cmx \
-    middle_end/flambda_utils.cmx middle_end/flambda.cmx \
-    bytecomp/debuginfo.cmx middle_end/base_types/closure_id.cmx \
-    utils/clflags.cmx middle_end/backend_intf.cmi \
-    middle_end/augment_specialised_args.cmi
+    middle_end/projection.cmx middle_end/pass_wrapper.cmx utils/misc.cmx \
+    middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \
+    utils/identifiable.cmx middle_end/flambda_utils.cmx \
+    middle_end/flambda.cmx middle_end/debuginfo.cmx \
+    middle_end/base_types/closure_id.cmx utils/clflags.cmx \
+    middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi
+middle_end/augment_specialised_args.cmi : middle_end/base_types/variable.cmi \
+    middle_end/projection.cmi middle_end/inlining_cost.cmi \
+    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi
+middle_end/backend_intf.cmi : middle_end/base_types/symbol.cmi \
+    middle_end/simple_value_approx.cmi typing/ident.cmi \
+    middle_end/base_types/closure_id.cmi
 middle_end/closure_conversion.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
     middle_end/base_types/static_exception.cmi bytecomp/simplif.cmi \
@@ -1305,12 +1200,11 @@ middle_end/closure_conversion.cmo : middle_end/base_types/variable.cmi \
     utils/misc.cmi parsing/location.cmi \
     middle_end/base_types/linkage_name.cmi middle_end/lift_code.cmi \
     bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_utils.cmi \
-    middle_end/flambda.cmi bytecomp/debuginfo.cmi \
+    middle_end/flambda.cmi middle_end/debuginfo.cmi utils/config.cmi \
     middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi \
     middle_end/closure_conversion_aux.cmi utils/clflags.cmi \
-    middle_end/backend_intf.cmi parsing/asttypes.cmi \
-    middle_end/closure_conversion.cmi
+    middle_end/backend_intf.cmi middle_end/closure_conversion.cmi
 middle_end/closure_conversion.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
     middle_end/base_types/static_exception.cmx bytecomp/simplif.cmx \
@@ -1319,30 +1213,40 @@ middle_end/closure_conversion.cmx : middle_end/base_types/variable.cmx \
     utils/misc.cmx parsing/location.cmx \
     middle_end/base_types/linkage_name.cmx middle_end/lift_code.cmx \
     bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_utils.cmx \
-    middle_end/flambda.cmx bytecomp/debuginfo.cmx \
+    middle_end/flambda.cmx middle_end/debuginfo.cmx utils/config.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx \
     middle_end/closure_conversion_aux.cmx utils/clflags.cmx \
-    middle_end/backend_intf.cmi parsing/asttypes.cmi \
-    middle_end/closure_conversion.cmi
+    middle_end/backend_intf.cmi middle_end/closure_conversion.cmi
+middle_end/closure_conversion.cmi : bytecomp/lambda.cmi typing/ident.cmi \
+    middle_end/flambda.cmi middle_end/backend_intf.cmi
 middle_end/closure_conversion_aux.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/symbol.cmi \
     middle_end/base_types/static_exception.cmi typing/primitive.cmi \
     utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
-    utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
+    utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
     middle_end/closure_conversion_aux.cmi
 middle_end/closure_conversion_aux.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/symbol.cmx \
     middle_end/base_types/static_exception.cmx typing/primitive.cmx \
     utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \
-    utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
+    utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
     middle_end/closure_conversion_aux.cmi
+middle_end/closure_conversion_aux.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/symbol.cmi \
+    middle_end/base_types/static_exception.cmi \
+    middle_end/base_types/mutable_variable.cmi parsing/location.cmi \
+    bytecomp/lambda.cmi typing/ident.cmi
+middle_end/debuginfo.cmo : parsing/location.cmi middle_end/debuginfo.cmi
+middle_end/debuginfo.cmx : parsing/location.cmx middle_end/debuginfo.cmi
+middle_end/debuginfo.cmi : parsing/location.cmi
 middle_end/effect_analysis.cmo : middle_end/semantics_of_primitives.cmi \
     utils/misc.cmi bytecomp/lambda.cmi middle_end/flambda.cmi \
     middle_end/effect_analysis.cmi
 middle_end/effect_analysis.cmx : middle_end/semantics_of_primitives.cmx \
     utils/misc.cmx bytecomp/lambda.cmx middle_end/flambda.cmx \
     middle_end/effect_analysis.cmi
+middle_end/effect_analysis.cmi : middle_end/flambda.cmi
 middle_end/extract_projections.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/simple_value_approx.cmi middle_end/projection.cmi \
@@ -1355,12 +1259,17 @@ middle_end/extract_projections.cmx : middle_end/base_types/variable.cmx \
     middle_end/inline_and_simplify_aux.cmx middle_end/freshening.cmx \
     middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
     middle_end/base_types/closure_id.cmx middle_end/extract_projections.cmi
+middle_end/extract_projections.cmi : middle_end/base_types/variable.cmi \
+    middle_end/projection.cmi middle_end/inline_and_simplify_aux.cmi \
+    middle_end/flambda.cmi
 middle_end/find_recursive_functions.cmo : middle_end/base_types/variable.cmi \
     utils/strongly_connected_components.cmi middle_end/flambda_utils.cmi \
     middle_end/flambda.cmi middle_end/find_recursive_functions.cmi
 middle_end/find_recursive_functions.cmx : middle_end/base_types/variable.cmx \
     utils/strongly_connected_components.cmx middle_end/flambda_utils.cmx \
     middle_end/flambda.cmx middle_end/find_recursive_functions.cmi
+middle_end/find_recursive_functions.cmi : middle_end/base_types/variable.cmi \
+    middle_end/flambda.cmi middle_end/backend_intf.cmi
 middle_end/flambda.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
     middle_end/base_types/static_exception.cmi \
@@ -1368,7 +1277,7 @@ middle_end/flambda.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
     bytecomp/printlambda.cmi utils/numbers.cmi \
     middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
-    bytecomp/lambda.cmi utils/identifiable.cmi bytecomp/debuginfo.cmi \
+    bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi utils/clflags.cmi \
     parsing/asttypes.cmi middle_end/allocated_const.cmi \
@@ -1380,11 +1289,20 @@ middle_end/flambda.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \
     bytecomp/printlambda.cmx utils/numbers.cmx \
     middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
-    bytecomp/lambda.cmx utils/identifiable.cmx bytecomp/debuginfo.cmx \
+    bytecomp/lambda.cmx utils/identifiable.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     parsing/asttypes.cmi middle_end/allocated_const.cmx \
     middle_end/flambda.cmi
+middle_end/flambda.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
+    middle_end/base_types/static_exception.cmi \
+    middle_end/base_types/set_of_closures_origin.cmi \
+    middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
+    utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
+    bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \
+    middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \
+    middle_end/allocated_const.cmi
 middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
@@ -1394,7 +1312,7 @@ middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \
     bytecomp/printlambda.cmi utils/numbers.cmi \
     middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
     bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_iterators.cmi \
-    middle_end/flambda.cmi bytecomp/debuginfo.cmi \
+    middle_end/flambda.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \
     middle_end/allocated_const.cmi middle_end/flambda_invariants.cmi
@@ -1407,14 +1325,17 @@ middle_end/flambda_invariants.cmx : middle_end/base_types/variable.cmx \
     bytecomp/printlambda.cmx utils/numbers.cmx \
     middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
     bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_iterators.cmx \
-    middle_end/flambda.cmx bytecomp/debuginfo.cmx \
+    middle_end/flambda.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx parsing/asttypes.cmi \
     middle_end/allocated_const.cmx middle_end/flambda_invariants.cmi
+middle_end/flambda_invariants.cmi : middle_end/flambda.cmi
 middle_end/flambda_iterators.cmo : middle_end/base_types/variable.cmi \
     utils/misc.cmi middle_end/flambda.cmi middle_end/flambda_iterators.cmi
 middle_end/flambda_iterators.cmx : middle_end/base_types/variable.cmx \
     utils/misc.cmx middle_end/flambda.cmx middle_end/flambda_iterators.cmi
+middle_end/flambda_iterators.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/symbol.cmi middle_end/flambda.cmi
 middle_end/flambda_utils.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/symbol.cmi bytecomp/switch.cmi \
@@ -1422,7 +1343,7 @@ middle_end/flambda_utils.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
     middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
     middle_end/base_types/linkage_name.cmi middle_end/flambda_iterators.cmi \
-    middle_end/flambda.cmi bytecomp/debuginfo.cmi \
+    middle_end/flambda.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
     middle_end/allocated_const.cmi middle_end/flambda_utils.cmi
@@ -1433,10 +1354,17 @@ middle_end/flambda_utils.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \
     middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
     middle_end/base_types/linkage_name.cmx middle_end/flambda_iterators.cmx \
-    middle_end/flambda.cmx bytecomp/debuginfo.cmx \
+    middle_end/flambda.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
     middle_end/allocated_const.cmx middle_end/flambda_utils.cmi
+middle_end/flambda_utils.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/var_within_closure.cmi \
+    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
+    bytecomp/switch.cmi middle_end/base_types/static_exception.cmi \
+    middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
+    middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \
+    middle_end/backend_intf.cmi
 middle_end/freshening.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/symbol.cmi \
@@ -1453,6 +1381,12 @@ middle_end/freshening.cmx : middle_end/base_types/variable.cmx \
     utils/identifiable.cmx middle_end/flambda_utils.cmx \
     middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
     middle_end/base_types/closure_id.cmx middle_end/freshening.cmi
+middle_end/freshening.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/var_within_closure.cmi \
+    middle_end/base_types/symbol.cmi \
+    middle_end/base_types/static_exception.cmi \
+    middle_end/base_types/mutable_variable.cmi middle_end/flambda.cmi \
+    middle_end/base_types/closure_id.cmi
 middle_end/inconstant_idents.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/symbol.cmi \
     middle_end/base_types/set_of_closures_id.cmi utils/numbers.cmi \
@@ -1469,12 +1403,16 @@ middle_end/inconstant_idents.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
     parsing/asttypes.cmi middle_end/inconstant_idents.cmi
+middle_end/inconstant_idents.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/set_of_closures_id.cmi middle_end/flambda.cmi \
+    middle_end/base_types/compilation_unit.cmi middle_end/backend_intf.cmi
 middle_end/initialize_symbol_to_let_symbol.cmo : \
     middle_end/base_types/variable.cmi utils/misc.cmi middle_end/flambda.cmi \
     middle_end/initialize_symbol_to_let_symbol.cmi
 middle_end/initialize_symbol_to_let_symbol.cmx : \
     middle_end/base_types/variable.cmx utils/misc.cmx middle_end/flambda.cmx \
     middle_end/initialize_symbol_to_let_symbol.cmi
+middle_end/initialize_symbol_to_let_symbol.cmi : middle_end/flambda.cmi
 middle_end/inline_and_simplify.cmo : utils/warnings.cmi \
     middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
@@ -1492,7 +1430,7 @@ middle_end/inline_and_simplify.cmo : utils/warnings.cmi \
     middle_end/inline_and_simplify_aux.cmi typing/ident.cmi \
     middle_end/freshening.cmi middle_end/flambda_utils.cmi \
     middle_end/flambda.cmi middle_end/effect_analysis.cmi \
-    bytecomp/debuginfo.cmi middle_end/base_types/closure_id.cmi \
+    middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi \
     utils/clflags.cmi middle_end/backend_intf.cmi \
     middle_end/allocated_const.cmi middle_end/inline_and_simplify.cmi
 middle_end/inline_and_simplify.cmx : utils/warnings.cmx \
@@ -1512,19 +1450,21 @@ middle_end/inline_and_simplify.cmx : utils/warnings.cmx \
     middle_end/inline_and_simplify_aux.cmx typing/ident.cmx \
     middle_end/freshening.cmx middle_end/flambda_utils.cmx \
     middle_end/flambda.cmx middle_end/effect_analysis.cmx \
-    bytecomp/debuginfo.cmx middle_end/base_types/closure_id.cmx \
+    middle_end/debuginfo.cmx middle_end/base_types/closure_id.cmx \
     utils/clflags.cmx middle_end/backend_intf.cmi \
     middle_end/allocated_const.cmx middle_end/inline_and_simplify.cmi
+middle_end/inline_and_simplify.cmi : middle_end/base_types/variable.cmi \
+    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
+    middle_end/backend_intf.cmi
 middle_end/inline_and_simplify_aux.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/symbol.cmi \
     middle_end/base_types/static_exception.cmi \
     middle_end/simple_value_approx.cmi \
     middle_end/base_types/set_of_closures_origin.cmi \
-    middle_end/projection.cmi utils/numbers.cmi \
-    middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
-    middle_end/inlining_stats.cmi middle_end/inlining_cost.cmi \
-    middle_end/freshening.cmi middle_end/flambda.cmi \
+    middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \
+    utils/misc.cmi middle_end/inlining_stats.cmi middle_end/inlining_cost.cmi \
+    middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi utils/clflags.cmi \
     middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmi
@@ -1534,13 +1474,21 @@ middle_end/inline_and_simplify_aux.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/static_exception.cmx \
     middle_end/simple_value_approx.cmx \
     middle_end/base_types/set_of_closures_origin.cmx \
-    middle_end/projection.cmx utils/numbers.cmx \
-    middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
-    middle_end/inlining_stats.cmx middle_end/inlining_cost.cmx \
-    middle_end/freshening.cmx middle_end/flambda.cmx \
+    middle_end/projection.cmx middle_end/base_types/mutable_variable.cmx \
+    utils/misc.cmx middle_end/inlining_stats.cmx middle_end/inlining_cost.cmx \
+    middle_end/freshening.cmx middle_end/flambda.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     middle_end/backend_intf.cmi middle_end/inline_and_simplify_aux.cmi
+middle_end/inline_and_simplify_aux.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/symbol.cmi \
+    middle_end/base_types/static_exception.cmi \
+    middle_end/simple_value_approx.cmi \
+    middle_end/base_types/set_of_closures_origin.cmi \
+    middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \
+    middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \
+    middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \
+    middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi
 middle_end/inlining_cost.cmo : middle_end/base_types/variable.cmi \
     middle_end/projection.cmi typing/primitive.cmi utils/misc.cmi \
     bytecomp/lambda.cmi middle_end/flambda_iterators.cmi \
@@ -1549,6 +1497,8 @@ middle_end/inlining_cost.cmx : middle_end/base_types/variable.cmx \
     middle_end/projection.cmx typing/primitive.cmx utils/misc.cmx \
     bytecomp/lambda.cmx middle_end/flambda_iterators.cmx \
     middle_end/flambda.cmx utils/clflags.cmx middle_end/inlining_cost.cmi
+middle_end/inlining_cost.cmi : middle_end/projection.cmi \
+    middle_end/flambda.cmi
 middle_end/inlining_decision.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/simple_value_approx.cmi utils/misc.cmi bytecomp/lambda.cmi \
@@ -1567,32 +1517,53 @@ middle_end/inlining_decision.cmx : middle_end/base_types/variable.cmx \
     middle_end/find_recursive_functions.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     middle_end/inlining_decision.cmi
+middle_end/inlining_decision.cmi : middle_end/base_types/variable.cmi \
+    middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
+    middle_end/inlining_decision_intf.cmi \
+    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
+    middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
+middle_end/inlining_decision_intf.cmi : middle_end/base_types/variable.cmi \
+    middle_end/simple_value_approx.cmi middle_end/inline_and_simplify_aux.cmi \
+    middle_end/flambda.cmi middle_end/debuginfo.cmi \
+    middle_end/base_types/closure_id.cmi
 middle_end/inlining_stats.cmo : utils/misc.cmi \
-    middle_end/inlining_stats_types.cmi bytecomp/debuginfo.cmi \
+    middle_end/inlining_stats_types.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/closure_id.cmi utils/clflags.cmi \
     middle_end/inlining_stats.cmi
 middle_end/inlining_stats.cmx : utils/misc.cmx \
-    middle_end/inlining_stats_types.cmx bytecomp/debuginfo.cmx \
+    middle_end/inlining_stats_types.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     middle_end/inlining_stats.cmi
+middle_end/inlining_stats.cmi : middle_end/inlining_stats_types.cmi \
+    middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
 middle_end/inlining_stats_types.cmo : middle_end/inlining_cost.cmi \
     middle_end/inlining_stats_types.cmi
 middle_end/inlining_stats_types.cmx : middle_end/inlining_cost.cmx \
     middle_end/inlining_stats_types.cmi
+middle_end/inlining_stats_types.cmi : middle_end/inlining_cost.cmi
 middle_end/inlining_transforms.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/simple_value_approx.cmi utils/misc.cmi bytecomp/lambda.cmi \
     middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
-    middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
-    middle_end/flambda.cmi middle_end/base_types/compilation_unit.cmi \
-    middle_end/base_types/closure_id.cmi middle_end/inlining_transforms.cmi
+    middle_end/freshening.cmi middle_end/flambda_utils.cmi \
+    middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
+    middle_end/base_types/compilation_unit.cmi \
+    middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
+    middle_end/inlining_transforms.cmi
 middle_end/inlining_transforms.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/var_within_closure.cmx \
     middle_end/simple_value_approx.cmx utils/misc.cmx bytecomp/lambda.cmx \
     middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \
-    middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
-    middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \
-    middle_end/base_types/closure_id.cmx middle_end/inlining_transforms.cmi
+    middle_end/freshening.cmx middle_end/flambda_utils.cmx \
+    middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
+    middle_end/base_types/compilation_unit.cmx \
+    middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
+    middle_end/inlining_transforms.cmi
+middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \
+    middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
+    middle_end/inlining_decision_intf.cmi \
+    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
+    middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
 middle_end/invariant_params.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \
     middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
@@ -1603,16 +1574,18 @@ middle_end/invariant_params.cmx : middle_end/base_types/variable.cmx \
     middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     middle_end/backend_intf.cmi middle_end/invariant_params.cmi
+middle_end/invariant_params.cmi : middle_end/base_types/variable.cmi \
+    middle_end/flambda.cmi middle_end/backend_intf.cmi
 middle_end/lift_code.cmo : middle_end/base_types/variable.cmi \
-    utils/strongly_connected_components.cmi \
-    middle_end/simple_value_approx.cmi middle_end/inlining_cost.cmi \
-    middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
-    middle_end/base_types/compilation_unit.cmi middle_end/lift_code.cmi
+    utils/strongly_connected_components.cmi middle_end/flambda_iterators.cmi \
+    middle_end/flambda.cmi middle_end/base_types/compilation_unit.cmi \
+    middle_end/lift_code.cmi
 middle_end/lift_code.cmx : middle_end/base_types/variable.cmx \
-    utils/strongly_connected_components.cmx \
-    middle_end/simple_value_approx.cmx middle_end/inlining_cost.cmx \
-    middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
-    middle_end/base_types/compilation_unit.cmx middle_end/lift_code.cmi
+    utils/strongly_connected_components.cmx middle_end/flambda_iterators.cmx \
+    middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \
+    middle_end/lift_code.cmi
+middle_end/lift_code.cmi : middle_end/base_types/variable.cmi \
+    middle_end/flambda.cmi
 middle_end/lift_constants.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
@@ -1635,16 +1608,20 @@ middle_end/lift_constants.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
     parsing/asttypes.cmi middle_end/allocated_const.cmx \
     middle_end/alias_analysis.cmx middle_end/lift_constants.cmi
+middle_end/lift_constants.cmi : middle_end/flambda.cmi \
+    middle_end/backend_intf.cmi
 middle_end/lift_let_to_initialize_symbol.cmo : \
     middle_end/base_types/variable.cmi middle_end/base_types/tag.cmi \
     middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \
-    middle_end/flambda.cmi bytecomp/debuginfo.cmi parsing/asttypes.cmi \
+    middle_end/flambda.cmi middle_end/debuginfo.cmi parsing/asttypes.cmi \
     middle_end/lift_let_to_initialize_symbol.cmi
 middle_end/lift_let_to_initialize_symbol.cmx : \
     middle_end/base_types/variable.cmx middle_end/base_types/tag.cmx \
     middle_end/base_types/symbol.cmx middle_end/flambda_utils.cmx \
-    middle_end/flambda.cmx bytecomp/debuginfo.cmx parsing/asttypes.cmi \
+    middle_end/flambda.cmx middle_end/debuginfo.cmx parsing/asttypes.cmi \
     middle_end/lift_let_to_initialize_symbol.cmi
+middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \
+    middle_end/backend_intf.cmi
 middle_end/middle_end.cmo : utils/warnings.cmi \
     middle_end/base_types/variable.cmi utils/timings.cmi \
     middle_end/base_types/symbol.cmi middle_end/share_constants.cmi \
@@ -1656,7 +1633,7 @@ middle_end/middle_end.cmo : utils/warnings.cmi \
     middle_end/inlining_cost.cmi middle_end/inline_and_simplify.cmi \
     middle_end/initialize_symbol_to_let_symbol.cmi \
     middle_end/flambda_iterators.cmi middle_end/flambda_invariants.cmi \
-    middle_end/flambda.cmi bytecomp/debuginfo.cmi \
+    middle_end/flambda.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/closure_id.cmi middle_end/closure_conversion.cmi \
     utils/clflags.cmi middle_end/backend_intf.cmi middle_end/middle_end.cmi
 middle_end/middle_end.cmx : utils/warnings.cmx \
@@ -1670,25 +1647,34 @@ middle_end/middle_end.cmx : utils/warnings.cmx \
     middle_end/inlining_cost.cmx middle_end/inline_and_simplify.cmx \
     middle_end/initialize_symbol_to_let_symbol.cmx \
     middle_end/flambda_iterators.cmx middle_end/flambda_invariants.cmx \
-    middle_end/flambda.cmx bytecomp/debuginfo.cmx \
+    middle_end/flambda.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/closure_id.cmx middle_end/closure_conversion.cmx \
     utils/clflags.cmx middle_end/backend_intf.cmi middle_end/middle_end.cmi
+middle_end/middle_end.cmi : utils/timings.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi middle_end/flambda.cmi middle_end/backend_intf.cmi
 middle_end/pass_wrapper.cmo : utils/clflags.cmi middle_end/pass_wrapper.cmi
 middle_end/pass_wrapper.cmx : utils/clflags.cmx middle_end/pass_wrapper.cmi
+middle_end/pass_wrapper.cmi :
 middle_end/projection.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi utils/identifiable.cmi \
     middle_end/base_types/closure_id.cmi middle_end/projection.cmi
 middle_end/projection.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/var_within_closure.cmx utils/identifiable.cmx \
     middle_end/base_types/closure_id.cmx middle_end/projection.cmi
+middle_end/projection.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/var_within_closure.cmi utils/identifiable.cmi \
+    middle_end/base_types/closure_id.cmi
 middle_end/ref_to_variables.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
-    middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
-    parsing/asttypes.cmi middle_end/ref_to_variables.cmi
+    bytecomp/lambda.cmi middle_end/flambda_iterators.cmi \
+    middle_end/flambda.cmi parsing/asttypes.cmi \
+    middle_end/ref_to_variables.cmi
 middle_end/ref_to_variables.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
-    middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
-    parsing/asttypes.cmi middle_end/ref_to_variables.cmi
+    bytecomp/lambda.cmx middle_end/flambda_iterators.cmx \
+    middle_end/flambda.cmx parsing/asttypes.cmi \
+    middle_end/ref_to_variables.cmi
+middle_end/ref_to_variables.cmi : middle_end/flambda.cmi
 middle_end/remove_free_vars_equal_to_args.cmo : \
     middle_end/base_types/variable.cmi middle_end/pass_wrapper.cmi \
     middle_end/flambda_utils.cmi middle_end/flambda.cmi \
@@ -1697,6 +1683,7 @@ middle_end/remove_free_vars_equal_to_args.cmx : \
     middle_end/base_types/variable.cmx middle_end/pass_wrapper.cmx \
     middle_end/flambda_utils.cmx middle_end/flambda.cmx \
     middle_end/remove_free_vars_equal_to_args.cmi
+middle_end/remove_free_vars_equal_to_args.cmi : middle_end/flambda.cmi
 middle_end/remove_unused_arguments.cmo : middle_end/base_types/variable.cmi \
     middle_end/projection.cmi middle_end/invariant_params.cmi \
     middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
@@ -1711,6 +1698,8 @@ middle_end/remove_unused_arguments.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     middle_end/remove_unused_arguments.cmi
+middle_end/remove_unused_arguments.cmi : middle_end/flambda.cmi \
+    middle_end/backend_intf.cmi
 middle_end/remove_unused_closure_vars.cmo : \
     middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi middle_end/flambda_utils.cmi \
@@ -1723,6 +1712,7 @@ middle_end/remove_unused_closure_vars.cmx : \
     middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
     middle_end/base_types/closure_id.cmx \
     middle_end/remove_unused_closure_vars.cmi
+middle_end/remove_unused_closure_vars.cmi : middle_end/flambda.cmi
 middle_end/remove_unused_program_constructs.cmo : \
     middle_end/base_types/symbol.cmi utils/misc.cmi middle_end/flambda.cmi \
     middle_end/effect_analysis.cmi \
@@ -1731,32 +1721,40 @@ middle_end/remove_unused_program_constructs.cmx : \
     middle_end/base_types/symbol.cmx utils/misc.cmx middle_end/flambda.cmx \
     middle_end/effect_analysis.cmx \
     middle_end/remove_unused_program_constructs.cmi
+middle_end/remove_unused_program_constructs.cmi : middle_end/flambda.cmi
 middle_end/semantics_of_primitives.cmo : bytecomp/printlambda.cmi \
     utils/misc.cmi bytecomp/lambda.cmi middle_end/semantics_of_primitives.cmi
 middle_end/semantics_of_primitives.cmx : bytecomp/printlambda.cmx \
     utils/misc.cmx bytecomp/lambda.cmx middle_end/semantics_of_primitives.cmi
+middle_end/semantics_of_primitives.cmi : bytecomp/lambda.cmi
 middle_end/share_constants.cmo : middle_end/base_types/symbol.cmi \
     middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
     middle_end/share_constants.cmi
 middle_end/share_constants.cmx : middle_end/base_types/symbol.cmx \
     middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
     middle_end/share_constants.cmi
+middle_end/share_constants.cmi : middle_end/flambda.cmi
 middle_end/simple_value_approx.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
-    utils/misc.cmi middle_end/inlining_cost.cmi middle_end/freshening.cmi \
-    middle_end/flambda_utils.cmi middle_end/flambda.cmi \
-    middle_end/base_types/export_id.cmi middle_end/effect_analysis.cmi \
-    middle_end/base_types/closure_id.cmi middle_end/allocated_const.cmi \
-    middle_end/simple_value_approx.cmi
+    utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
+    middle_end/freshening.cmi middle_end/flambda_utils.cmi \
+    middle_end/flambda.cmi middle_end/base_types/export_id.cmi \
+    middle_end/effect_analysis.cmi middle_end/base_types/closure_id.cmi \
+    middle_end/allocated_const.cmi middle_end/simple_value_approx.cmi
 middle_end/simple_value_approx.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/var_within_closure.cmx \
     middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
-    utils/misc.cmx middle_end/inlining_cost.cmx middle_end/freshening.cmx \
-    middle_end/flambda_utils.cmx middle_end/flambda.cmx \
-    middle_end/base_types/export_id.cmx middle_end/effect_analysis.cmx \
-    middle_end/base_types/closure_id.cmx middle_end/allocated_const.cmx \
-    middle_end/simple_value_approx.cmi
+    utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
+    middle_end/freshening.cmx middle_end/flambda_utils.cmx \
+    middle_end/flambda.cmx middle_end/base_types/export_id.cmx \
+    middle_end/effect_analysis.cmx middle_end/base_types/closure_id.cmx \
+    middle_end/allocated_const.cmx middle_end/simple_value_approx.cmi
+middle_end/simple_value_approx.cmi : middle_end/base_types/variable.cmi \
+    middle_end/base_types/var_within_closure.cmi \
+    middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
+    bytecomp/lambda.cmi middle_end/freshening.cmi middle_end/flambda.cmi \
+    middle_end/base_types/export_id.cmi middle_end/base_types/closure_id.cmi
 middle_end/simplify_boxed_integer_ops.cmo : middle_end/simplify_common.cmi \
     middle_end/simplify_boxed_integer_ops_intf.cmi \
     middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
@@ -1765,24 +1763,37 @@ middle_end/simplify_boxed_integer_ops.cmx : middle_end/simplify_common.cmx \
     middle_end/simplify_boxed_integer_ops_intf.cmi \
     middle_end/simple_value_approx.cmx bytecomp/lambda.cmx \
     middle_end/inlining_cost.cmx middle_end/simplify_boxed_integer_ops.cmi
+middle_end/simplify_boxed_integer_ops.cmi : \
+    middle_end/simplify_boxed_integer_ops_intf.cmi
+middle_end/simplify_boxed_integer_ops_intf.cmi : \
+    middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
+    middle_end/inlining_cost.cmi middle_end/flambda.cmi
 middle_end/simplify_common.cmo : middle_end/simple_value_approx.cmi \
     bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
     middle_end/effect_analysis.cmi middle_end/simplify_common.cmi
 middle_end/simplify_common.cmx : middle_end/simple_value_approx.cmx \
     bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
     middle_end/effect_analysis.cmx middle_end/simplify_common.cmi
+middle_end/simplify_common.cmi : middle_end/simple_value_approx.cmi \
+    bytecomp/lambda.cmi middle_end/inlining_cost.cmi middle_end/flambda.cmi
 middle_end/simplify_primitives.cmo : middle_end/base_types/tag.cmi \
     middle_end/base_types/symbol.cmi middle_end/simplify_common.cmi \
     middle_end/simplify_boxed_integer_ops.cmi \
-    middle_end/simple_value_approx.cmi utils/misc.cmi bytecomp/lambda.cmi \
-    middle_end/inlining_cost.cmi middle_end/flambda.cmi utils/clflags.cmi \
-    parsing/asttypes.cmi middle_end/simplify_primitives.cmi
+    middle_end/simple_value_approx.cmi middle_end/semantics_of_primitives.cmi \
+    utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
+    middle_end/flambda.cmi utils/clflags.cmi parsing/asttypes.cmi \
+    middle_end/simplify_primitives.cmi
 middle_end/simplify_primitives.cmx : middle_end/base_types/tag.cmx \
     middle_end/base_types/symbol.cmx middle_end/simplify_common.cmx \
     middle_end/simplify_boxed_integer_ops.cmx \
-    middle_end/simple_value_approx.cmx utils/misc.cmx bytecomp/lambda.cmx \
-    middle_end/inlining_cost.cmx middle_end/flambda.cmx utils/clflags.cmx \
-    parsing/asttypes.cmi middle_end/simplify_primitives.cmi
+    middle_end/simple_value_approx.cmx middle_end/semantics_of_primitives.cmx \
+    utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
+    middle_end/flambda.cmx utils/clflags.cmx parsing/asttypes.cmi \
+    middle_end/simplify_primitives.cmi
+middle_end/simplify_primitives.cmi : middle_end/base_types/variable.cmi \
+    middle_end/simple_value_approx.cmi bytecomp/lambda.cmi \
+    middle_end/inlining_cost.cmi middle_end/flambda.cmi \
+    middle_end/debuginfo.cmi
 middle_end/unbox_closures.cmo : middle_end/base_types/variable.cmi \
     middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
     middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
@@ -1795,6 +1806,9 @@ middle_end/unbox_closures.cmx : middle_end/base_types/variable.cmx \
     middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \
     utils/clflags.cmx middle_end/augment_specialised_args.cmx \
     middle_end/unbox_closures.cmi
+middle_end/unbox_closures.cmi : middle_end/base_types/variable.cmi \
+    middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
+    middle_end/flambda.cmi
 middle_end/unbox_free_vars_of_closures.cmo : \
     middle_end/base_types/variable.cmi middle_end/projection.cmi \
     middle_end/pass_wrapper.cmi utils/misc.cmi middle_end/inlining_cost.cmi \
@@ -1807,6 +1821,8 @@ middle_end/unbox_free_vars_of_closures.cmx : \
     middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
     middle_end/flambda.cmx middle_end/extract_projections.cmx \
     utils/clflags.cmx middle_end/unbox_free_vars_of_closures.cmi
+middle_end/unbox_free_vars_of_closures.cmi : middle_end/inlining_cost.cmi \
+    middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi
 middle_end/unbox_specialised_args.cmo : middle_end/base_types/variable.cmi \
     middle_end/projection.cmi middle_end/invariant_params.cmi \
     middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
@@ -1819,51 +1835,35 @@ middle_end/unbox_specialised_args.cmx : middle_end/base_types/variable.cmx \
     middle_end/extract_projections.cmx utils/clflags.cmx \
     middle_end/augment_specialised_args.cmx \
     middle_end/unbox_specialised_args.cmi
-middle_end/base_types/closure_element.cmi : \
-    middle_end/base_types/variable.cmi utils/identifiable.cmi \
-    middle_end/base_types/compilation_unit.cmi
-middle_end/base_types/closure_id.cmi : \
-    middle_end/base_types/closure_element.cmi
-middle_end/base_types/compilation_unit.cmi : \
-    middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \
-    typing/ident.cmi
-middle_end/base_types/export_id.cmi : utils/identifiable.cmi \
-    middle_end/base_types/compilation_unit.cmi
-middle_end/base_types/id_types.cmi : utils/identifiable.cmi
-middle_end/base_types/linkage_name.cmi : utils/identifiable.cmi
-middle_end/base_types/mutable_variable.cmi : utils/identifiable.cmi \
-    typing/ident.cmi middle_end/base_types/compilation_unit.cmi
-middle_end/base_types/set_of_closures_id.cmi : utils/identifiable.cmi \
-    middle_end/base_types/compilation_unit.cmi
-middle_end/base_types/set_of_closures_origin.cmi : \
-    middle_end/base_types/set_of_closures_id.cmi utils/identifiable.cmi \
-    middle_end/base_types/compilation_unit.cmi
-middle_end/base_types/static_exception.cmi : utils/identifiable.cmi
-middle_end/base_types/symbol.cmi : middle_end/base_types/linkage_name.cmi \
-    utils/identifiable.cmi middle_end/base_types/compilation_unit.cmi
-middle_end/base_types/tag.cmi : utils/identifiable.cmi
-middle_end/base_types/var_within_closure.cmi : \
-    middle_end/base_types/closure_element.cmi
-middle_end/base_types/variable.cmi : utils/identifiable.cmi typing/ident.cmi \
-    middle_end/base_types/compilation_unit.cmi
+middle_end/unbox_specialised_args.cmi : middle_end/base_types/variable.cmi \
+    middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
+    middle_end/flambda.cmi
 middle_end/base_types/closure_element.cmo : \
     middle_end/base_types/variable.cmi \
     middle_end/base_types/closure_element.cmi
 middle_end/base_types/closure_element.cmx : \
     middle_end/base_types/variable.cmx \
     middle_end/base_types/closure_element.cmi
+middle_end/base_types/closure_element.cmi : \
+    middle_end/base_types/variable.cmi utils/identifiable.cmi \
+    middle_end/base_types/compilation_unit.cmi
 middle_end/base_types/closure_id.cmo : \
     middle_end/base_types/closure_element.cmi \
     middle_end/base_types/closure_id.cmi
 middle_end/base_types/closure_id.cmx : \
     middle_end/base_types/closure_element.cmx \
     middle_end/base_types/closure_id.cmi
+middle_end/base_types/closure_id.cmi : \
+    middle_end/base_types/closure_element.cmi
 middle_end/base_types/compilation_unit.cmo : utils/misc.cmi \
     middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \
     typing/ident.cmi middle_end/base_types/compilation_unit.cmi
 middle_end/base_types/compilation_unit.cmx : utils/misc.cmx \
     middle_end/base_types/linkage_name.cmx utils/identifiable.cmx \
     typing/ident.cmx middle_end/base_types/compilation_unit.cmi
+middle_end/base_types/compilation_unit.cmi : \
+    middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \
+    typing/ident.cmi
 middle_end/base_types/export_id.cmo : utils/identifiable.cmi \
     middle_end/base_types/id_types.cmi \
     middle_end/base_types/compilation_unit.cmi \
@@ -1872,20 +1872,26 @@ middle_end/base_types/export_id.cmx : utils/identifiable.cmx \
     middle_end/base_types/id_types.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/export_id.cmi
+middle_end/base_types/export_id.cmi : utils/identifiable.cmi \
+    middle_end/base_types/compilation_unit.cmi
 middle_end/base_types/id_types.cmo : utils/identifiable.cmi \
     middle_end/base_types/id_types.cmi
 middle_end/base_types/id_types.cmx : utils/identifiable.cmx \
     middle_end/base_types/id_types.cmi
+middle_end/base_types/id_types.cmi : utils/identifiable.cmi
 middle_end/base_types/linkage_name.cmo : utils/identifiable.cmi \
     middle_end/base_types/linkage_name.cmi
 middle_end/base_types/linkage_name.cmx : utils/identifiable.cmx \
     middle_end/base_types/linkage_name.cmi
+middle_end/base_types/linkage_name.cmi : utils/identifiable.cmi
 middle_end/base_types/mutable_variable.cmo : utils/identifiable.cmi \
     typing/ident.cmi middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/mutable_variable.cmi
 middle_end/base_types/mutable_variable.cmx : utils/identifiable.cmx \
     typing/ident.cmx middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/mutable_variable.cmi
+middle_end/base_types/mutable_variable.cmi : utils/identifiable.cmi \
+    typing/ident.cmi middle_end/base_types/compilation_unit.cmi
 middle_end/base_types/set_of_closures_id.cmo : utils/identifiable.cmi \
     middle_end/base_types/id_types.cmi \
     middle_end/base_types/compilation_unit.cmi \
@@ -1894,16 +1900,22 @@ middle_end/base_types/set_of_closures_id.cmx : utils/identifiable.cmx \
     middle_end/base_types/id_types.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/set_of_closures_id.cmi
+middle_end/base_types/set_of_closures_id.cmi : utils/identifiable.cmi \
+    middle_end/base_types/compilation_unit.cmi
 middle_end/base_types/set_of_closures_origin.cmo : \
     middle_end/base_types/set_of_closures_id.cmi \
     middle_end/base_types/set_of_closures_origin.cmi
 middle_end/base_types/set_of_closures_origin.cmx : \
     middle_end/base_types/set_of_closures_id.cmx \
     middle_end/base_types/set_of_closures_origin.cmi
+middle_end/base_types/set_of_closures_origin.cmi : \
+    middle_end/base_types/set_of_closures_id.cmi utils/identifiable.cmi \
+    middle_end/base_types/compilation_unit.cmi
 middle_end/base_types/static_exception.cmo : utils/numbers.cmi \
     bytecomp/lambda.cmi middle_end/base_types/static_exception.cmi
 middle_end/base_types/static_exception.cmx : utils/numbers.cmx \
     bytecomp/lambda.cmx middle_end/base_types/static_exception.cmi
+middle_end/base_types/static_exception.cmi : utils/identifiable.cmi
 middle_end/base_types/symbol.cmo : utils/misc.cmi \
     middle_end/base_types/linkage_name.cmi utils/identifiable.cmi \
     middle_end/base_types/compilation_unit.cmi \
@@ -1912,54 +1924,54 @@ middle_end/base_types/symbol.cmx : utils/misc.cmx \
     middle_end/base_types/linkage_name.cmx utils/identifiable.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/symbol.cmi
+middle_end/base_types/symbol.cmi : middle_end/base_types/linkage_name.cmi \
+    utils/identifiable.cmi middle_end/base_types/compilation_unit.cmi
 middle_end/base_types/tag.cmo : utils/numbers.cmi utils/misc.cmi \
     utils/identifiable.cmi middle_end/base_types/tag.cmi
 middle_end/base_types/tag.cmx : utils/numbers.cmx utils/misc.cmx \
     utils/identifiable.cmx middle_end/base_types/tag.cmi
+middle_end/base_types/tag.cmi : utils/identifiable.cmi
 middle_end/base_types/var_within_closure.cmo : \
     middle_end/base_types/closure_element.cmi \
     middle_end/base_types/var_within_closure.cmi
 middle_end/base_types/var_within_closure.cmx : \
     middle_end/base_types/closure_element.cmx \
     middle_end/base_types/var_within_closure.cmi
+middle_end/base_types/var_within_closure.cmi : \
+    middle_end/base_types/closure_element.cmi
 middle_end/base_types/variable.cmo : utils/misc.cmi utils/identifiable.cmi \
     typing/ident.cmi middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/variable.cmi
 middle_end/base_types/variable.cmx : utils/misc.cmx utils/identifiable.cmx \
     typing/ident.cmx middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/variable.cmi
-driver/compenv.cmi :
-driver/compile.cmi :
-driver/compmisc.cmi : typing/env.cmi
-driver/errors.cmi :
-driver/main.cmi :
-driver/main_args.cmi :
-driver/optcompile.cmi : middle_end/backend_intf.cmi
-driver/opterrors.cmi :
-driver/optmain.cmi :
-driver/pparse.cmi : parsing/parsetree.cmi
+middle_end/base_types/variable.cmi : utils/identifiable.cmi typing/ident.cmi \
+    middle_end/base_types/compilation_unit.cmi
+driver/compdynlink.cmi :
 driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \
-    utils/config.cmi utils/clflags.cmi driver/compenv.cmi
+    utils/config.cmi utils/clflags.cmi utils/ccomp.cmi driver/compenv.cmi
 driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \
-    utils/config.cmx utils/clflags.cmx driver/compenv.cmi
+    utils/config.cmx utils/clflags.cmx utils/ccomp.cmx driver/compenv.cmi
+driver/compenv.cmi :
 driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
     typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
     utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
     typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
     bytecomp/printinstr.cmi parsing/printast.cmi parsing/pprintast.cmi \
-    driver/pparse.cmi utils/misc.cmi parsing/location.cmi \
+    driver/pparse.cmi utils/misc.cmi bytecomp/lambda.cmi \
     typing/includemod.cmi typing/env.cmi bytecomp/emitcode.cmi \
-    driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi utils/ccomp.cmi \
+    driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
     bytecomp/bytegen.cmi parsing/builtin_attributes.cmi driver/compile.cmi
 driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
     typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
     utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
     typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
     bytecomp/printinstr.cmx parsing/printast.cmx parsing/pprintast.cmx \
-    driver/pparse.cmx utils/misc.cmx parsing/location.cmx \
+    driver/pparse.cmx utils/misc.cmx bytecomp/lambda.cmx \
     typing/includemod.cmx typing/env.cmx bytecomp/emitcode.cmx \
-    driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx utils/ccomp.cmx \
+    driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
     bytecomp/bytegen.cmx parsing/builtin_attributes.cmx driver/compile.cmi
+driver/compile.cmi :
 driver/compmisc.cmo : typing/typemod.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
     typing/env.cmi utils/config.cmi driver/compenv.cmi utils/clflags.cmi \
@@ -1968,22 +1980,33 @@ driver/compmisc.cmx : typing/typemod.cmx utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
     typing/env.cmx utils/config.cmx driver/compenv.cmx utils/clflags.cmx \
     parsing/asttypes.cmi driver/compmisc.cmi
+driver/compmisc.cmi : typing/env.cmi
+driver/compplugin.cmo : utils/misc.cmi parsing/location.cmi utils/config.cmi \
+    driver/compmisc.cmi driver/compenv.cmi driver/compdynlink.cmi \
+    utils/clflags.cmi driver/compplugin.cmi
+driver/compplugin.cmx : utils/misc.cmx parsing/location.cmx utils/config.cmx \
+    driver/compmisc.cmx driver/compenv.cmx driver/compdynlink.cmi \
+    utils/clflags.cmx driver/compplugin.cmi
+driver/compplugin.cmi :
 driver/errors.cmo : parsing/location.cmi driver/errors.cmi
 driver/errors.cmx : parsing/location.cmx driver/errors.cmi
+driver/errors.cmi :
 driver/main.cmo : utils/warnings.cmi utils/timings.cmi utils/misc.cmi \
     driver/main_args.cmi parsing/location.cmi utils/config.cmi \
-    driver/compmisc.cmi driver/compile.cmi driver/compenv.cmi \
-    utils/clflags.cmi bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
-    bytecomp/bytelibrarian.cmi driver/main.cmi
+    driver/compplugin.cmi driver/compmisc.cmi driver/compile.cmi \
+    driver/compenv.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \
+    bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi
 driver/main.cmx : utils/warnings.cmx utils/timings.cmx utils/misc.cmx \
     driver/main_args.cmx parsing/location.cmx utils/config.cmx \
-    driver/compmisc.cmx driver/compile.cmx driver/compenv.cmx \
-    utils/clflags.cmx bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
-    bytecomp/bytelibrarian.cmx driver/main.cmi
-driver/main_args.cmo : utils/warnings.cmi utils/clflags.cmi \
+    driver/compplugin.cmx driver/compmisc.cmx driver/compile.cmx \
+    driver/compenv.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \
+    bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi
+driver/main.cmi :
+driver/main_args.cmo : utils/warnings.cmi utils/config.cmi utils/clflags.cmi \
     driver/main_args.cmi
-driver/main_args.cmx : utils/warnings.cmx utils/clflags.cmx \
+driver/main_args.cmx : utils/warnings.cmx utils/config.cmx utils/clflags.cmx \
     driver/main_args.cmi
+driver/main_args.cmi :
 driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
     typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
     utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
@@ -1992,8 +2015,7 @@ driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
     utils/misc.cmi middle_end/middle_end.cmi bytecomp/lambda.cmi \
     typing/includemod.cmi typing/env.cmi utils/config.cmi driver/compmisc.cmi \
     asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \
-    utils/ccomp.cmi parsing/builtin_attributes.cmi asmcomp/asmgen.cmi \
-    driver/optcompile.cmi
+    parsing/builtin_attributes.cmi asmcomp/asmgen.cmi driver/optcompile.cmi
 driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \
     typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
     utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
@@ -2002,44 +2024,35 @@ driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \
     utils/misc.cmx middle_end/middle_end.cmx bytecomp/lambda.cmx \
     typing/includemod.cmx typing/env.cmx utils/config.cmx driver/compmisc.cmx \
     asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \
-    utils/ccomp.cmx parsing/builtin_attributes.cmx asmcomp/asmgen.cmx \
-    driver/optcompile.cmi
+    parsing/builtin_attributes.cmx asmcomp/asmgen.cmx driver/optcompile.cmi
+driver/optcompile.cmi : middle_end/backend_intf.cmi
 driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi
 driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi
+driver/opterrors.cmi :
 driver/optmain.cmo : utils/warnings.cmi utils/timings.cmi asmcomp/proc.cmi \
     asmcomp/printmach.cmi driver/optcompile.cmi utils/misc.cmi \
     driver/main_args.cmi parsing/location.cmi asmcomp/import_approx.cmi \
-    utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \
-    driver/compenv.cmi utils/clflags.cmi middle_end/backend_intf.cmi \
-    asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \
-    asmcomp/arch.cmo driver/optmain.cmi
+    utils/config.cmi driver/compplugin.cmi driver/compmisc.cmi \
+    asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \
+    middle_end/backend_intf.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \
+    asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi
 driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx asmcomp/proc.cmx \
     asmcomp/printmach.cmx driver/optcompile.cmx utils/misc.cmx \
     driver/main_args.cmx parsing/location.cmx asmcomp/import_approx.cmx \
-    utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \
-    driver/compenv.cmx utils/clflags.cmx middle_end/backend_intf.cmi \
-    asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \
-    asmcomp/arch.cmx driver/optmain.cmi
-driver/pparse.cmo : utils/timings.cmi parsing/parse.cmi utils/misc.cmi \
-    parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
-    parsing/ast_mapper.cmi parsing/ast_invariants.cmi driver/pparse.cmi
-driver/pparse.cmx : utils/timings.cmx parsing/parse.cmx utils/misc.cmx \
-    parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
-    parsing/ast_mapper.cmx parsing/ast_invariants.cmx driver/pparse.cmi
-toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \
-    typing/outcometree.cmi typing/env.cmi
-toplevel/opttopdirs.cmi : parsing/longident.cmi
-toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \
-    typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \
-    parsing/longident.cmi parsing/location.cmi typing/env.cmi
-toplevel/opttopmain.cmi :
-toplevel/topdirs.cmi : parsing/longident.cmi
-toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
-    parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \
-    parsing/location.cmi typing/env.cmi
-toplevel/topmain.cmi :
-toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
-    typing/env.cmi
+    utils/config.cmx driver/compplugin.cmx driver/compmisc.cmx \
+    asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \
+    middle_end/backend_intf.cmi asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \
+    asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi
+driver/optmain.cmi :
+driver/pparse.cmo : utils/timings.cmi parsing/parsetree.cmi \
+    parsing/parse.cmi utils/misc.cmi parsing/location.cmi utils/config.cmi \
+    utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \
+    parsing/ast_invariants.cmi driver/pparse.cmi
+driver/pparse.cmx : utils/timings.cmx parsing/parsetree.cmi \
+    parsing/parse.cmx utils/misc.cmx parsing/location.cmx utils/config.cmx \
+    utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \
+    parsing/ast_invariants.cmx driver/pparse.cmi
+driver/pparse.cmi : parsing/parsetree.cmi utils/misc.cmi
 toplevel/expunge.cmo : bytecomp/symtable.cmi bytecomp/runtimedef.cmi \
     utils/misc.cmi typing/ident.cmi bytecomp/bytesections.cmi
 toplevel/expunge.cmx : bytecomp/symtable.cmx bytecomp/runtimedef.cmx \
@@ -2054,16 +2067,19 @@ toplevel/genprintval.cmx : typing/types.cmx typing/printtyp.cmx \
     typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \
     typing/env.cmx typing/datarepr.cmx typing/ctype.cmx typing/btype.cmx \
     toplevel/genprintval.cmi
+toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \
+    typing/outcometree.cmi typing/env.cmi
 toplevel/opttopdirs.cmo : utils/warnings.cmi typing/types.cmi \
     typing/printtyp.cmi toplevel/opttoploop.cmi utils/misc.cmi \
     parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
-    utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \
-    toplevel/opttopdirs.cmi
+    utils/config.cmi driver/compdynlink.cmi utils/clflags.cmi \
+    asmcomp/asmlink.cmi toplevel/opttopdirs.cmi
 toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \
     typing/printtyp.cmx toplevel/opttoploop.cmx utils/misc.cmx \
     parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
-    utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \
-    toplevel/opttopdirs.cmi
+    utils/config.cmx driver/compdynlink.cmi utils/clflags.cmx \
+    asmcomp/asmlink.cmx toplevel/opttopdirs.cmi
+toplevel/opttopdirs.cmi : parsing/longident.cmi
 toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \
     typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
     bytecomp/translmod.cmi utils/timings.cmi bytecomp/simplif.cmi \
@@ -2075,10 +2091,10 @@ toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \
     parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \
     bytecomp/lambda.cmi typing/includemod.cmi asmcomp/import_approx.cmi \
     typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \
-    driver/compmisc.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
-    typing/btype.cmi middle_end/backend_intf.cmi parsing/asttypes.cmi \
-    parsing/ast_helper.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
-    asmcomp/arch.cmo toplevel/opttoploop.cmi
+    driver/compmisc.cmi asmcomp/compilenv.cmi driver/compdynlink.cmi \
+    utils/clflags.cmi typing/btype.cmi middle_end/backend_intf.cmi \
+    parsing/asttypes.cmi parsing/ast_helper.cmi asmcomp/asmlink.cmi \
+    asmcomp/asmgen.cmi asmcomp/arch.cmo toplevel/opttoploop.cmi
 toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \
     typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
     bytecomp/translmod.cmx utils/timings.cmx bytecomp/simplif.cmx \
@@ -2090,18 +2106,24 @@ toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \
     parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \
     bytecomp/lambda.cmx typing/includemod.cmx asmcomp/import_approx.cmx \
     typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \
-    driver/compmisc.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
-    typing/btype.cmx middle_end/backend_intf.cmi parsing/asttypes.cmi \
-    parsing/ast_helper.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
-    asmcomp/arch.cmx toplevel/opttoploop.cmi
+    driver/compmisc.cmx asmcomp/compilenv.cmx driver/compdynlink.cmi \
+    utils/clflags.cmx typing/btype.cmx middle_end/backend_intf.cmi \
+    parsing/asttypes.cmi parsing/ast_helper.cmx asmcomp/asmlink.cmx \
+    asmcomp/asmgen.cmx asmcomp/arch.cmx toplevel/opttoploop.cmi
+toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \
+    typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/env.cmi
 toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
     toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \
     driver/main_args.cmi parsing/location.cmi utils/config.cmi \
-    driver/compenv.cmi utils/clflags.cmi toplevel/opttopmain.cmi
+    driver/compplugin.cmi driver/compenv.cmi utils/clflags.cmi \
+    toplevel/opttopmain.cmi
 toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
     toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \
     driver/main_args.cmx parsing/location.cmx utils/config.cmx \
-    driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi
+    driver/compplugin.cmx driver/compenv.cmx utils/clflags.cmx \
+    toplevel/opttopmain.cmi
+toplevel/opttopmain.cmi :
 toplevel/opttopstart.cmo : toplevel/opttopmain.cmi
 toplevel/opttopstart.cmx : toplevel/opttopmain.cmx
 toplevel/topdirs.cmo : utils/warnings.cmi typing/typetexp.cmi \
@@ -2122,6 +2144,7 @@ toplevel/topdirs.cmx : utils/warnings.cmx typing/typetexp.cmx \
     utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \
     utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
     toplevel/topdirs.cmi
+toplevel/topdirs.cmi : parsing/longident.cmi
 toplevel/toploop.cmo : utils/warnings.cmi typing/typetexp.cmi \
     typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \
     typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \
@@ -2133,7 +2156,7 @@ toplevel/toploop.cmo : utils/warnings.cmi typing/typetexp.cmi \
     parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \
     typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \
     bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
-    utils/config.cmi driver/compmisc.cmi utils/clflags.cmi \
+    utils/config.cmi driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
     bytecomp/bytegen.cmi typing/btype.cmi parsing/asttypes.cmi \
     parsing/ast_helper.cmi toplevel/toploop.cmi
 toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \
@@ -2147,17 +2170,21 @@ toplevel/toploop.cmx : utils/warnings.cmx typing/typetexp.cmx \
     parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \
     typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \
     bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \
-    utils/config.cmx driver/compmisc.cmx utils/clflags.cmx \
+    utils/config.cmx driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
     bytecomp/bytegen.cmx typing/btype.cmx parsing/asttypes.cmi \
     parsing/ast_helper.cmx toplevel/toploop.cmi
+toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
+    parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/env.cmi
 toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \
     toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \
-    parsing/location.cmi utils/config.cmi driver/compenv.cmi \
-    utils/clflags.cmi toplevel/topmain.cmi
+    parsing/location.cmi utils/config.cmi driver/compplugin.cmi \
+    driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi
 toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \
     toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \
-    parsing/location.cmx utils/config.cmx driver/compenv.cmx \
-    utils/clflags.cmx toplevel/topmain.cmi
+    parsing/location.cmx utils/config.cmx driver/compplugin.cmx \
+    driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi
+toplevel/topmain.cmi :
 toplevel/topstart.cmo : toplevel/topmain.cmi
 toplevel/topstart.cmx : toplevel/topmain.cmx
 toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \
@@ -2168,3 +2195,10 @@ toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \
     typing/printtyp.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
     bytecomp/meta.cmx parsing/longident.cmx typing/ctype.cmx \
     parsing/asttypes.cmi toplevel/trace.cmi
+toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
+    typing/env.cmi
+driver/compdynlink.cmx : asmcomp/cmx_format.cmi driver/compdynlink.cmi
+driver/compdynlink.cmo : bytecomp/symtable.cmi bytecomp/opcodes.cmo \
+    utils/misc.cmi bytecomp/meta.cmi bytecomp/dll.cmi utils/consistbl.cmi \
+    utils/config.cmi bytecomp/cmo_format.cmi typing/cmi_format.cmi \
+    driver/compdynlink.cmi

diff --git a/.gitattributes b/.gitattributes
index d83330eece2196d98a2a62f7df405f3e8d5a96a8..be13cb1a01d11c785a5039d2c90c559e47f709d1 100644 (file)
--- a/.gitattributes
+++ b/.gitattributes
@@ -17,9 +17,9 @@
 * text=auto
 
 # Binary files
-boot/ocamlc binary
-boot/ocamllex binary
-boot/ocamldep binary
+/boot/ocamlc binary
+/boot/ocamllex binary
+/boot/ocamldep binary
 *.gif binary
 *.png binary
 *.tfm binary
@@ -29,11 +29,12 @@ boot/ocamldep binary
 README*                  ocaml-typo=missing-header
 *.adoc                   ocaml-typo=missing-header,long-line,unused-prop
 
-/.merlin                  ocaml-typo=missing-header
-/Changes                  ocaml-typo=non-ascii,missing-header
-/INSTALL                  ocaml-typo=missing-header
-/LICENSE                  ocaml-typo=non-printing,missing-header
-/appveyor.yml             ocaml-typo=long-line,very-long-line
+/.mailmap                ocaml-typo=long-line,missing-header,non-ascii
+/.merlin                 ocaml-typo=missing-header
+/Changes                 ocaml-typo=non-ascii,missing-header
+/INSTALL                 ocaml-typo=missing-header
+/LICENSE                 ocaml-typo=long-line,very-long-line,missing-header
+/appveyor.yml            ocaml-typo=long-line,very-long-line
 
 
 asmcomp/*/emit.mlp       ocaml-typo=tab,long-line,unused-prop
@@ -63,10 +64,9 @@ otherlibs/win32unix/readlink.c    ocaml-typo=long-line
 otherlibs/win32unix/stat.c        ocaml-typo=long-line
 otherlibs/win32unix/symlink.c     ocaml-typo=long-line
 
-stdlib/sharpbang    ocaml-typo=white-at-eol,missing-lf
+stdlib/hashbang     ocaml-typo=white-at-eol,missing-lf
 
-# FIXME remove headers in testsuite/tests and remove unused-prop in next line:
-testsuite/tests/**                        ocaml-typo=missing-header,unused-prop
+testsuite/tests/**                        ocaml-typo=missing-header
 testsuite/tests/lib-bigarray-2/bigarrf.f  ocaml-typo=missing-header,tab
 testsuite/tests/misc-unsafe/almabench.ml  ocaml-typo=missing-header,long-line
 testsuite/typing                          ocaml-typo=missing-header
@@ -125,3 +125,6 @@ manual/tools/texexpand text eol=lf
 # Checking out the parsetree test files with \r\n endings causes all the
 # locations to change, so use \n endings only, even on Windows
 testsuite/tests/parsing/*.ml text eol=lf
+
+# Similarly, the docstring tests fail for the same reason on Windows
+testsuite/tests/docstrings/empty.ml text eol=lf

diff --git a/.gitignore b/.gitignore
index 095b8acff4335b7fe885bab638b81972848315b9..332ecb86374c1c93dec1dfccc243789575689950 100644 (file)
--- a/.gitignore
+++ b/.gitignore
@@ -110,6 +110,7 @@
 /byterun/caml/version.h
 /byterun/ocamlrun
 /byterun/ocamlrund
+/byterun/ocamlruni
 /byterun/ld.conf
 /byterun/interp.a.lst
 /byterun/*.[sd]obj
@@ -125,8 +126,9 @@
 /debugger/parser.ml
 /debugger/parser.mli
 /debugger/ocamldebug
-/debugger/dynlink.ml
-/debugger/dynlink.mli
+/driver/compdynlink.mlopt
+/driver/compdynlink.mlbyte
+/driver/compdynlink.mli
 
 /emacs/ocamltags
 /emacs/*.elc
@@ -225,6 +227,7 @@
 
 /testsuite/**/*.result
 /testsuite/**/*.opt_result
+/testsuite/**/*.corrected
 /testsuite/**/*.byte
 /testsuite/**/*.native
 /testsuite/**/program
@@ -239,8 +242,14 @@
 /testsuite/tests/asmcomp/*.s
 /testsuite/tests/asmcomp/*.out.manifest
 
+/testsuite/tests/basic/*.safe-string
+/testsuite/tests/basic/pr6322.ml
+
 /testsuite/tests/embedded/caml
 
+/testsuite/tests/float-unboxing/*.flambda
+/testsuite/tests/float-unboxing/float_inline.ml
+
 /testsuite/tests/lib-dynlink-bytecode/main
 /testsuite/tests/lib-dynlink-bytecode/static
 /testsuite/tests/lib-dynlink-bytecode/custom
@@ -262,6 +271,8 @@
 
 /testsuite/tests/runtime-errors/*.bytecode
 
+/testsuite/tests/self-contained-toplevel/cached_cmi.ml
+
 /testsuite/tests/tool-debugger/**/compiler-libs
 /testsuite/tests/tool-debugger/find-artifacts/out
 /testsuite/tests/tool-debugger/no_debug_event/out
@@ -281,10 +292,24 @@
 
 /testsuite/tests/tool-ocamldoc-2/ocamldoc.sty
 
+/testsuite/tests/tool-ocamldoc-html/*.html
+/testsuite/tests/tool-ocamldoc-html/style.css
+
+/testsuite/tests/tool-ocamldoc-man/*.3o
+
+/testsuite/tests/tool-ocamldoc-open/alias.odoc
+/testsuite/tests/tool-ocamldoc-open/inner.odoc
+/testsuite/tests/tool-ocamldoc-open/main.odoc
+/testsuite/tests/tool-ocamldoc-open/ocamldoc.sty
+
 /testsuite/tests/tool-lexyacc/scanner.ml
 /testsuite/tests/tool-lexyacc/grammar.mli
 /testsuite/tests/tool-lexyacc/grammar.ml
 
+/testsuite/tests/typing-multifile/a.ml
+/testsuite/tests/typing-multifile/b.ml
+/testsuite/tests/typing-multifile/c.ml
+
 /testsuite/tests/unboxed-primitive-args/main.ml
 /testsuite/tests/unboxed-primitive-args/stubs.c
 
@@ -293,26 +318,37 @@
 /testsuite/tests/warnings/w55.opt.opt_result
 /testsuite/tests/warnings/w58.opt.opt_result
 
+/testsuite/tools/expect_test
+
 /tools/ocamldep
 /tools/ocamldep.opt
 /tools/ocamldep.bak
 /tools/ocamlprof
+/tools/ocamlprof.opt
 /tools/opnames.ml
 /tools/dumpobj
+/tools/dumpobj.opt
 /tools/dumpapprox
-/tools/objinfo
+/tools/ocamlobjinfo
+/tools/ocamlobjinfo.opt
 /tools/cvt_emit
+/tools/cvt_emit.opt
 /tools/cvt_emit.bak
 /tools/cvt_emit.ml
 /tools/ocamlcp
+/tools/ocamlcp.opt
 /tools/ocamloptp
+/tools/ocamloptp.opt
 /tools/ocamlmktop
+/tools/ocamlmktop.opt
 /tools/primreq
+/tools/primreq.opt
 /tools/ocamldumpobj
 /tools/keywords
 /tools/lexer299.ml
 /tools/ocaml299to3
 /tools/ocamlmklib
+/tools/ocamlmklib.opt
 /tools/ocamlmklibconfig.ml
 /tools/lexer301.ml
 /tools/scrapelabels
@@ -321,7 +357,9 @@
 /tools/read_cmt
 /tools/read_cmt.opt
 /tools/cmpbyt
+/tools/cmpbyt.opt
 /tools/stripdebug
+/tools/stripdebug.opt
 
 /utils/config.ml
 

diff --git a/.mailmap b/.mailmap
new file mode 100644 (file)
index 0000000..96b5234
--- /dev/null
+++ b/.mailmap
@@ -0,0 +1,76 @@
+# The format of this file is generally of the form
+# <correct authorship information> <information found in commit message>
+# for example:
+# Proper Name <commit@email>
+# <proper@email> <commit@email>
+# Proper Name <proper@email> Commit Name <commit@email>
+#
+# See the MAPPING AUTHORS section of 'man git-shortlog' for more details.
+
+# Such a remapping may be useful in particular for tracking authorship
+# of commits erroneously made under an obscure alias or email adress.
+# (Some Name <some@name.com>, pour ne pas le citer)
+
+Alain Frisch <alain@frisch.fr> alainfrisch <alain@frisch.fr>
+<damien.doligez@inria.fr> <damien.doligez-inria.fr>
+<damien.doligez@inria.fr> <damien.doligez@gmail.com>
+<luc.maranget@inria.fr> <Luc.Maranget@inria.fr>
+<luc.maranget@inria.fr> <maranget@pl-59086.rocq.inria.fr>
+<pierre.chambart@ocamlpro.com> <chambart@users.noreply.github.com>
+<xavier.leroy@inria.fr> <xavierleroy@users.noreply.github.com>
+<leo@lpw25.net> <lpw25@cl.cam.ac.uk>
+<Jerome.Vouillon@pps.jussieu.fr> <jerome.vouillon@pps.univ-paris-diderot.fr>
+cvs2svn <no_author@ocaml.org>
+Damien Doligez <damien.doligez@inria.fr> Some Name <some@name.com>
+Damien Doligez <damien.doligez@inria.fr> doligez <damien.doligez@inria.fr>
+Mohamed Iguernelala <mohamed.iguernelala@gmail.com>
+Jérémie Dimino <jdimino@janestreet.com>
+
+# The aliases below correspond to preference expressed by
+# contributors on the name under which they credited, for example
+# if they use an opaque nickname from github or mantis:
+#
+#   Preferred Name <email> nickname <contribution-email>
+# or
+#   Preferred Name <nickname@mantis.com>
+#   Preferred Name <nickname>@github.com
+# to indicate a preference associated to a Mantis account.
+
+Florian Angeletti <octa@polychoron.fr> octachron <octa@polychoron.fr>
+Gabriel Radanne <drupyog@zoho.com> Drup <drupyog@zoho.com>
+Pierre Weis <Pierre.Weis@inria.fr> pierreweis <Pierre.Weis@inria.fr>
+John Christopher McAlpine <christophermcalpine@gmail.com> chrismamo1 <christophermcalpine@gmail.com>
+Runhang Li <runhang@posteo.de> marklrh <marklrh@gmail.com>
+Francis Souther <francis.southern@gmail.com> FDSouthern <francis.southern@gmail.com>
+Simon Cruanes <simon.cruanes.2007@m4x.org> <c-cube@mantis>
+Frederic Bour <frederic.bour@lakaban.net> <def@mantis>
+David Sheets <dsheets@mantis>
+David Allsopp <dra@mantis>
+Tim Cuthbertson <gfxmonk@mantis>
+Grégoire Henry <hnrgrgr@mantis>
+Julien Moutinho <julm@mantis>
+Adam Borowski <KiloByte@mantis>
+Mikhail Mandrykin <mandrykin@mantis>
+Maverick Woo <maverickwoo>
+Andi McClure <mcc>
+Michael Grünewald <michi>
+Michael O'Connor <mkoconnor>
+Florian Angeletti <octachron>
+Kenji Tokudome <pocarist>
+Philippe Veber <pveber>
+Valentin Gatien-Baron <sliquister>
+Stephen Dolan <stedolan>
+Junsong Li <lijunsong@mantis>
+Junsong Li <ljs.darkfish@gmail.com>
+Christophe Raffali <craff@mantis>
+Anton Bachin <antron@mantis>
+Reed Wilson <omion>
+David Scott <djs55>
+Martin Neuhäußer <sawfish@mantis>
+Goswin von Brederlow <mrvn>
+
+# These contributors prefer to be referred to pseudonymously
+<whitequark@mantis> <whitequark@mantis>
+<william@mantis> <william@mantis>
+tkob <ether4@gmail.com> tkob <ether4@gmail.com>
+ygrek <ygrek@autistici.org> ygrek <ygrek@autistici.org>

diff --git a/.travis-ci.sh b/.travis-ci.sh
index 8f847924b07365a450a78ddb24dea6cf4faafa91..a0df8aa109b5747a43f91cc3331723cf6b2cad7a 100755 (executable)
--- a/.travis-ci.sh
+++ b/.travis-ci.sh
@@ -21,7 +21,7 @@ BuildAndTest () {
   echo<<EOF
 ------------------------------------------------------------------------
 This test builds the OCaml compiler distribution with your pull request,
-runs its testsuite, and then tries to install some important OCaml softare
+runs its testsuite, and then tries to install some important OCaml software
 (currently camlp4) on top of it.
 
 Failing to build the compiler distribution, or testsuite failures are
@@ -40,6 +40,10 @@ EOF
     make install
     (cd testsuite && make all)
     (cd testsuite && make USE_RUNTIME="d" all)
+    # check_all_arches checks tries to compile all backends in place,
+    # we need to redo (small parts of) world.opt afterwards
+    make check_all_arches
+    make world.opt
     mkdir external-packages
     cd external-packages
     git clone git://github.com/ocaml/ocamlbuild
@@ -53,7 +57,7 @@ EOF
           OCAML_NATIVE_TOOLS=true &&
         make all &&
         make install)
-    git clone git://github.com/ocaml/camlp4 -b 4.03
+    git clone git://github.com/ocaml/camlp4 -b 4.04
     (cd camlp4 &&
      ./configure --bindir=$PREFIX/bin --libdir=$PREFIX/lib/ocaml \
        --pkgdir=$PREFIX/lib/ocaml && \
@@ -98,7 +102,7 @@ CheckTestsuiteModified () {
 This test checks that the OCaml testsuite has been modified by the
 pull request. Any new feature should come with tests, bugs should come
 with regression tests, and generally any change in behavior that can
-be exercized by a test should come with a test or modify and existing
+be exercised by a test should come with a test or modify and existing
 test. See our contributor documentation:
 
   https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#test-you-must

diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index f247668666c04683cf6a87ead83dabb7df533f82..23b21107e038858904c5488c7e6c86993ff52bee 100644 (file)
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -253,6 +253,54 @@ log -u` to make sure the rebase patches make sense), but:
   changes, or an un-testable intermediary state) is a sure way to
   generate ill will.
 
+## Contributing to the standard library
+
+Contributions to the standard library are very welcome.  There is some
+widespread belief in the community than the stdlib is somehow "frozen"
+and that its evolutions are mostly driven by the need of the OCaml
+compiler itself.  Let's be clear: this is just plain wrong. The
+compiler is happy with its own local utility functions, and many
+recent additions to the stdlib are not used by the compiler.
+
+Another common and wrong idea is that core OCaml maintainers don't
+really care about the standard library.  This is not true, and won't
+be unless one of the "alternative standard" libraries really gains
+enough "market share" in the community.
+
+So: please contribute!
+
+Obviously, the proposals to evolve the standard library will be
+evaluated with very high standards, similar to those applied to the
+evolution of the surface langage, and much higher than those for
+internal compiler changes (optimizations, etc).
+
+A key property of the standard library is its stability.  Backward
+compatibility is not an absolute technical requirement (any addition
+to/of a module can break existing code, formally), but breakage should
+be limited as much as possible (and assessed, when relevant).  A
+corollary is that any addition creates a long-term support commitment.
+For instance, once a concrete type or function is made public,
+changing the exposed definition cannot be done easily.
+
+There is no plan to extend dramatically the functional domain covered
+by the standard library.  For instance, proposals to include support
+for XML, JSON, or network protocols are very likely to be rejected.  Such
+domains are better treated by external libraries.  Small additions to
+existing modules are much simpler to get in, even more so (but not
+necessarily) when:
+
+  - they cannot easily be implemented externally, or when
+  - they facilitate communication between independent external
+    libraries, or when
+  - they fill obvious gaps.
+
+Of course, standard guidelines apply as well: proper documentation,
+proper tests, portability (yes, also Windows!), good justification for
+why the change is desirable and why it should go into stdlib.
+
+So: be prepared for some serious review process!  But yes, yes,
+contributions are welcome and appreciated.  Promised.
+
 
 ## Contributor License Agreement
 
@@ -290,3 +338,15 @@ contribution.
 This ability to re-license allows INRIA to provide members of the
 [Caml Consortium](http://caml.inria.fr/consortium/) with a license on
 the Caml code base that is more permissive than the public license.
+
+### How to sign the CLA
+
+If your contribution is large enough, you should sign the CLA. If you
+are contributing on your own behalf, you should sign [the individual
+CLA](http://caml.inria.fr/pub/docs/CLA-individual.doc). For corporate
+contributions, if your employer has not already done so, they should
+sign [the corporate
+CLA](http://caml.inria.fr/pub/docs/CLA-corporate.doc). Review the CLA,
+sign it, and send it -- scanned PDF by email, or postail mail -- to
+Xavier Leroy ([contact
+info](http://gallium.inria.fr/%7Exleroy/contact.html)).

diff --git a/Changes b/Changes
index 9e871450d6d0b0d791cbafd0da0f6cca954b9f3a..16a06c3079c8b381568e34c1b2b9257054dee639 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,10 +1,409 @@
-OCaml 4.03.0:
+OCaml 4.04.0:
 -------------
 
 (Changes that can break existing programs are marked with a "*")
 
-Language features:
-==================
+### Language features:
+
+- PR#7233: Support GADT equations on non-local abstract types
+  (Jacques Garrigue)
+
+- GPR#187, GPR#578: Local opening of modules in a pattern.
+  Syntax: "M.(p)", "M.[p]","M.[| p |]", "M.{p}"
+  (Florian Angeletti, Jacques Garrigue, review by Alain Frisch)
+
+- GPR#301: local exception declarations "let exception ... in"
+  (Alain Frisch)
+
+- GPR#508: Allow shortcut for extension on semicolons: ;%foo
+  (Jeremie Dimino)
+
+- GPR#606: optimized representation for immutable records with a single
+  field, and concrete types with a single constructor with a single argument.
+  This is triggered with a [@@unboxed] attribute on the type definition.
+  Currently mutually recursive datatypes are not well supported, this
+  limitation should be lifted in the future (see MPR#7364).
+  (Damien Doligez)
+
+### Compiler user-interface and warnings:
+
+* PR#6475, GPR#464: interpret all command-line options before compiling any
+  files, changes (improves) the semantics of repeated -o options or -o
+  combined with -c see the super-detailed commit message at
+  https://github.com/ocaml/ocaml/commit/da56cf6dfdc13c09905c2e07f1d4849c8346eec8
+  (whitequark)
+
+- PR#7139: clarify the wording of Warning 38
+  (Unused exception or extension constructor)
+  (Gabriel Scherer)
+
+* PR#7147, GPR#475: add colors when reporting errors generated by ppx rewriters.
+  Remove the `Location.errorf_prefixed` function which is no longer relevant
+  (Simon Cruanes, Jérémie Dimino)
+
+- PR#7169, GPR#501: clarify the wording of Warning 8
+  (Non-exhaustivity warning for pattern matching)
+  (Florian Angeletti, review and report by Gabriel Scherer)
+
+* GPR#591: Improve support for OCAMLPARAM: (i) do not use objects
+  files with -a, -pack, -shared; (ii) use "before" objects in the toplevel
+  (but not "after" objects); (iii) use -I dirs in the toplevel,
+  (iv) fix bug where -I dirs were ignored when using threads
+  (Marc Lasson, review by Damien Doligez and Alain Frisch)
+
+- GPR#648: New -plugin option for ocamlc and ocamlopt, to dynamically extend
+  the compilers at runtime.
+  (Fabrice Le Fessant)
+
+- GPR#684: Detect unused module declarations
+  (Alain Frisch)
+
+- GPR#706: Add a settable Env.Persistent_signature.load function so
+  that cmi files can be loaded from other sources. This can be used to
+  create self-contained toplevels.
+  (Jérémie Dimino)
+
+### Standard library:
+
+- GPR#473: Provide `Sys.backend_type` so that user can write backend-specific
+  code in some cases (for example,  code generator).
+  (Hongbo Zhang)
+
+- PR#6279, GPR#553: implement Set.map
+  (Gabriel Scherer)
+
+- PR#6820, GPR#560: Add Obj.reachable_words to compute the
+  "transitive" heap size of a value
+  (Alain Frisch, review by Mark Shinwell and Damien Doligez)
+
+- GPR#589: Add a non-allocating function to recover the number of
+  allocated minor words.
+  (Pierre Chambart, review by Damien Doligez and Gabriel Scherer)
+
+- GPR#626: String.split_on_char
+  (Alain Frisch)
+
+- GPR#669: Filename.extension and Filename.remove_extension
+  (Alain Frisch, request by Edgar Aroutiounian, review by Daniel Bunzli
+  and Damien Doligez)
+
+### Code generation and optimizations:
+
+- PR#4747, GPR#328: Optimize Hashtbl by using in-place updates of its
+  internal bucket lists.  All operations run in constant stack size
+  and are usually faster, except Hashtbl.copy which can be much
+  slower
+  (Alain Frisch)
+
+* PR#6217, GPR#538: Optimize performance of record update:
+  no more performance cliff when { foo with t1 = ..; t2 = ...; ... }
+  hits 6 updated fields
+  (Olivier Nicole, review by Thomas Braibant and Pierre Chambart)
+
+- PR#7023, GPR#336: Better unboxing strategy
+  (Alain Frisch, Pierre Chambart)
+
+- PR#7244, GPR#840: Ocamlopt + flambda requires a lot of memory
+  to compile large array literal expressions
+  (Pierre Chambart, review by Mark Shinwell)
+
+- PR#7291, GPR#780: Handle specialisation of recursive function that does
+  not always preserve the arguments
+  (Pierre Chambart, Mark Shinwell, report by Simon Cruanes)
+
+- GPR#427: Obj.is_block is now an inlined OCaml function instead of a
+  C external.  This should be faster.
+  (Demi Obenour)
+
+- GPR#580: Optimize immutable float records
+  (Pierre Chambart, review by Mark Shinwell)
+
+- GPR#602: Do not generate dummy code to force module linking
+  (Pierre Chambart, reviewed by Jacques Garrigue)
+
+- PR#7328, GPR#702: Do not eliminate boxed int divisions by zero and
+  avoid checking twice if divisor is zero with flambda.
+  (Pierre Chambart, report by Jeremy Yallop)
+
+- GPR#703: Optimize some constant string operations when the "-safe-string"
+  configure time option is enabled.
+  (Pierre Chambart)
+
+- GPR#707: Load cross module information during a meet
+  (Pierre Chambart, report by Leo White, review by Mark Shinwell)
+
+- GPR#709: Share a few more equal switch branches
+  (Pierre Chambart, review by Gabriel Scherer)
+
+- GPR#712: Small improvements to type-based optimizations for array
+  and lazy
+  (Alain Frisch, review by Pierre Chambart)
+
+- GPR#714: Prevent warning 59 from triggering on Lazy of constants
+  (Pierre Chambart, review by Leo White)
+
+- GPR#723 Sort emitted functions according to source location
+  (Pierre Chambart, review by Mark Shinwell)
+
+- Lack of type normalization lead to missing simple compilation for "lazy x"
+  (Alain Frisch)
+
+### Runtime system:
+
+- PR#7210, GPR#562: Allows to register finalisation function that are
+  called only when a value will never be reachable anymore. The
+  drawbacks compared to the existing one is that the finalisation
+  function is not called with the value as argument. These finalisers
+  are registered with `GC.finalise_last`
+  (François Bobot reviewed by Damien Doligez and Leo White)
+
+- GPR#590: Do not perform compaction if the real overhead is less than expected
+  (Thomas Braibant)
+
+### Tools:
+
+- PR#7189: toplevel #show, follow chains of module aliases
+  (Gabriel Scherer, report by Daniel Bünzli, review by Thomas Refis)
+
+- PR#7248: have ocamldep interpret -open arguments in left-to-right order
+  (Gabriel Scherer, report by Anton Bachin)
+
+- PR#7272, GPR#798: ocamldoc, missing line breaks in type_*.html files
+  (Florian Angeletti)
+
+- PR#7290: ocamldoc, improved support for inline records
+  (Florian Angeletti)
+
+- PR#7323, GPR#750: ensure "ocamllex -ml" works with -safe-string
+  (Hongbo Zhang)
+
+- PR#7350, GPR#806: ocamldoc, add viewport metadata to generated html pages
+  (Florian Angeletti, request by Daniel Bünzli)
+
+- GPR#452: Make the output of ocamldep more stable
+  (Alain Frisch)
+
+- GPR#548: empty documentation comments
+  (Florian Angeletti)
+
+- GPR#575: Add the -no-version option to the toplevel
+  (Sébastien Hinderer)
+
+- GPR#598: Add a --strict option to ocamlyacc treat conflicts as errors
+  (this option is now used for the compiler's parser)
+  (Jeremy Yallop)
+
+- GPR#613: make ocamldoc use -open arguments
+  (Florian Angeletti)
+
+- GPR#718: ocamldoc, fix order of extensible variant constructors
+  (Florian Angeletti)
+
+### Debugging and profiling:
+
+- GPR#585: Spacetime, a new memory profiler (Mark Shinwell, Leo White)
+
+### Runtime system:
+
+- PR#7203, GPR#534: Add a new primitive caml_alloc_float_array to allocate an
+  array of floats
+  (Thomas Braibant)
+
+### Manual and documentation:
+
+- PR#7007, PR#7311: document the existence of OCAMLPARAM and
+  ocaml_compiler_internal_params
+  (Damien Doligez, reports by Wim Lewis and Gabriel Scherer)
+
+- PR#7243: warn users against using WinZip to unpack the source archive
+  (Damien Doligez, report by Shayne Fletcher)
+
+- PR#7245, GPR#565: clarification to the wording and documentation
+  of Warning 52 (fragile constant pattern)
+  (Gabriel Scherer, William, Adrien Nader, Jacques Garrigue)
+
+- #PR7265, GPR#769: Restore 4.02.3 behaviour of Unix.fstat, if the
+  file descriptor doesn't wrap a regular file (win32unix only)
+  (Andreas Hauptmann, review by David Allsopp)
+
+- PR#7288: flatten : Avoid confusion
+  (Damien Doligez, report by user 'tormen')
+
+- PR#7355: Gc.finalise and lazy values
+  (Jeremy Yallop)
+
+- GPR#841: Document that [Store_field] must not be used to populate
+  arrays of values declared using [CAMLlocalN] (Mark Shinwell)
+
+### Build system:
+
+- GPR#324: Compiler developers: Adding new primitives to the
+  standard runtime doesn't require anymore to run `make bootstrap`
+  (François Bobot)
+
+- GPR#384: Fix compilation using old Microsoft C Compilers not
+  supporting secure CRT functions (SDK Visual Studio 2005 compiler and
+  earlier) and standard 64-bit integer literals (Visual Studio .NET
+  2002 and earlier)
+  (David Allsopp)
+
+- GPR#507: More sharing between Unix and Windows makefiles
+  (whitequark, review by Alain Frisch)
+
+* GPR#512, GPR#587: Installed `ocamlc`, `ocamlopt`, and `ocamllex` are
+  now the native-code versions of the tools, if those versions were
+  built.
+  (Demi Obenour)
+
+- GPR#687: "./configure -safe-string" to get a system where
+  "-unsafe-string" is not allowed, thus giving stronger non-local
+  guarantees about immutability of strings
+  (Alain Frisch, review by Hezekiah M. Carty)
+
+### Bug fixes:
+
+* PR#6505: Missed Type-error leads to a segfault upon record access.
+  (Jacques Garrigue, extra report by Stephen Dolan)
+  Proper fix required a more restrictive approach to recursive types:
+  mutually recursive types are seen as abstract types (i.e. non-contractive)
+  when checking the well-foundedness of the recursion.
+
+* PR#6752: Nominal types and scope escaping.
+  Revert to strict scope for non-generalizable type variables, cf. Mantis.
+  Note that this is actually stricter than the behavior before 4.03,
+  cf. PR#7313, meaning that you may sometimes need to add type annotations
+  to explicitly instantiate non-generalizable type variables.
+  (Jacques Garrigue, following discussion with Jeremy Yallop,
+   Nicolas Ojeda Bar and Alain Frisch)
+
+- PR#7112: Aliased arguments ignored for equality of module types
+  (Jacques Garrigue, report by Leo White)
+
+- PR#7134: compiler forcing aliases it shouldn't while reporting type errors
+  (Jacques Garrigue, report and suggestion by sliquister)
+
+- PR#7153: document that Unix.SOCK_SEQPACKET is not really usable.
+
+- PR#7165, GPR#494: uncaught exception on invalid lexer directive
+  (Gabriel Scherer, report by KC Sivaramakrishnan using afl-fuzz)
+
+- PR#7257, GPR#583: revert a 4.03 change of behavior on (Unix.sleep 0.),
+  it now calls (nano)sleep for 0 seconds as in (< 4.03) versions.
+  (Hannes Mehnert, review by Damien Doligez)
+
+- PR#7260: GADT + subtyping compile time crash
+  (Jacques Garrigue, report by Nicolas Ojeda Bar)
+
+- PR#7269: Segfault from conjunctive constraints in GADT
+  (Jacques Garrigue, report by Stephen Dolan)
+
+- PR#7276: Support more than FD_SETSIZE sockets in Windows' emulation
+  of select
+  (David Scott, review by Alain Frisch)
+
+* PR#7278: Prevent private inline records from being mutated
+  (Alain Frisch, report by Pierre Chambart)
+
+- PR#7284: Bug in mcomp_fields leads to segfault
+  (Jacques Garrigue, report by Leo White)
+
+- PR#7285: Relaxed value restriction broken with principal
+  (Jacques Garrigue, report by Leo White)
+
+- PR#7297: -strict-sequence turns off Warning 21
+  (Jacques Garrigue, report by Valentin Gatien-Baron)
+
+- PR#7299: remove access to OCaml heap inside blocking section in win32unix
+  (David Allsopp, report by Andreas Hauptmann)
+
+- PR#7300: remove access to OCaml heap inside blocking in Unix.sleep on Windows
+  (David Allsopp)
+
+- PR#7305: -principal causes loop in type checker when compiling
+  (Jacques Garrigue, report by Anil Madhavapeddy, analysis by Leo White)
+
+- PR#7330: Missing exhaustivity check for extensible variant
+  (Jacques Garrigue, report by Elarnon *)
+
+- PR#7374: Contractiveness check unsound with constraints
+  (Jacques Garrigue, report by Leo White)
+
+- PR#7378: GADT constructors can be re-exposed with an incompatible type
+  (Jacques Garrigue, report by Alain Frisch)
+
+- PR#7389: Unsoundness in GADT exhaustiveness with existential variables
+  (Jacques Garrigue, report by Stephen Dolan)
+
+* GPR#533: Thread library: fixed [Thread.wait_signal] so that it
+  converts back the signal number returned by [sigwait] to an
+  OS-independent number
+  (Jérémie Dimino)
+
+- GPR#600: (similar to GPR#555) ensure that register typing constraints are
+  respected at N-way join points in the control flow graph
+  (Mark Shinwell)
+
+- GPR#672: Fix float_of_hex parser to correctly reject some invalid forms
+  (Bogdan Tătăroiu, review by Thomas Braibant and Alain Frisch)
+
+- GPR#700: Fix maximum weak bucket size
+  (Nicolas Ojeda Bar, review by François Bobot)
+
+- GPR#708 Allow more module aliases in strengthening (Leo White)
+
+- GPR#713, PR#7301: Fix wrong code generation involving lazy values in Flambda
+  mode
+  (Mark Shinwell, review by Pierre Chambart and Alain Frisch)
+
+- GPR#721: Fix infinite loop in flambda due to [@@specialise] annotations
+
+- GPR#779: Building native runtime on Windows could fail when bootstrapping
+  FlexDLL if there was also a system-installed flexlink
+  (David Allsopp, report Michael Soegtrop)
+
+- GPR#805, GPR#815, GPR#833: check for integer overflow in String.concat
+  (Jeremy Yallop,
+   review by Damien Doligez, Alain Frisch, Daniel Bünzli, Fabrice Le Fessant)
+
+- GPR#810: check for integer overflow in Array.concat
+  (Jeremy Yallop)
+
+- GPR#814: fix the Buffer.add_substring bounds check to handle overflow
+  (Jeremy Yallop)
+
+- GPR#880: Fix [@@inline] with default parameters in flambda (Leo White)
+
+- GPR#525: fix build on OpenIndiana
+  (Sergey Avseyev, review by Damien Doligez)
+
+### Internal/compiler-libs changes:
+
+- PR#7200, GPR#539: Improve, fix, and add test for parsing/pprintast.ml
+  (Runhang Li, David Sheets, Alain Frisch)
+
+- GPR#351: make driver/pparse.ml functions type-safe
+  (Gabriel Scherer, Dmitrii Kosarev, review by Jérémie Dimino)
+
+- GPR#516: Improve Texp_record constructor representation, and
+  propagate updated record type information
+  (Pierre Chambart, review by Alain Frisch)
+
+- GPR#678: Graphics.close_graph crashes 64-bit Windows ports (re-implementation
+  of PR#3963)
+  (David Allsopp)
+
+- GPR#679: delay registration of docstring after the mapper is applied
+  (Hugo Heuzard, review by Leo White)
+
+- GPR#872: don't attach (**/**) comments to any particular node
+  (Thomas Refis, review by Leo White)
+
+OCaml 4.03.0 (25 Apr 2016):
+---------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+### Language features:
 
 - PR#5528: inline records for constructor arguments
   (Alain Frisch)
@@ -103,8 +502,7 @@ Language features:
   not to the expression.
   (Gabriel Radanne)
 
-Compilers:
-==========
+### Compilers:
 
 * PR#4231, PR#5461: warning 31 is now fatal by default
   (Warning 31: A module is linked twice in the same executable.)
@@ -277,8 +675,17 @@ Compilers:
   `match .. with exception e -> raise e`
   (Nicolas Ojeda Bar, review by Gabriel Scherer)
 
-Runtime system:
-===============
+### Runtime system:
+
+* GPR#596: make string/bytes distinguishable in the underlying
+  compiler implementation; caml_fill_string and caml_create_string are
+  deprecated and will be removed in the future, please use
+  caml_fill_bytes and caml_create_bytes for migration
+  (Hongbo Zhang, review by Damien Doligez, Alain Frisch, and Hugo Heuzard)
+
+- GPR#772 %string_safe_set and %string_unsafe_set are deprecated aliases
+  for %bytes_safe_set and %bytes_unsafe_set.
+  (Hongbo Zhang and Damien Doligez)
 
 - PR#3612, PR#92: allow allocating custom block with finalizers
   in the minor heap.
@@ -325,8 +732,7 @@ Runtime system:
 - GPR#325: Add v=0x400 flag to OCAMLRUNPARAM to display GC stats on exit
   (Louis Gesbert, review by Alain Frisch)
 
-Standard library:
-=================
+### Standard library:
 
 - PR#1460, GPR#230: Array.map2, Array.iter2
   (John Christopher McAlpine)
@@ -450,8 +856,7 @@ Standard library:
 - GPR#356: Add [Format.kasprintf]
   (Jérémie Dimino, Mark Shinwell)
 
-Type system:
-============
+### Type system:
 
 - PR#5545: Type annotations on methods cannot control the choice of abbreviation
   (Jacques Garrigue)
@@ -465,8 +870,7 @@ Type system:
 - PR#6593: Functor application in tests/basic-modules fails after commit 15405
   (Jacques Garrigue)
 
-Toplevel and debugger:
-======================
+### Toplevel and debugger:
 
 - PR#6113: Add descriptions to directives, and display them via #help
   (Nick Giannarakis, Berke Durak, Francis Southern and Gabriel Scherer)
@@ -501,8 +905,7 @@ Toplevel and debugger:
 - PR#7119: the toplevel does not respect [@@@warning]
   (Alain Frisch, report by Gabriel Radanne)
 
-Other libraries:
-================
+### Other libraries:
 
 * Unix library: channels created by Unix.in_channel_of_descr or
   Unix.out_channel_of_descr no longer support text mode under Windows.
@@ -552,14 +955,12 @@ Other libraries:
   similar functions when the [exec] call fails in the child process
   (Jérémie Dimino)
 
-OCamldep:
-=========
+### OCamldep:
 
 - GPR#286: add support for module aliases
   (Jacques Garrigue)
 
-Manual:
-=======
+### Manual:
 
 - GPR#302: The OCaml reference manual is now included in the manual/
   subdirectory of the main OCaml source repository. Contributions to
@@ -588,8 +989,7 @@ Manual:
 - PR#7109, GPR#380: Fix bigarray documentation layout
   (Florian Angeletti, Leo White)
 
-Bug fixes:
-==========
+### Bug fixes:
 
 - PR#3612: memory leak in bigarray read from file
   (Pierre Chambart, report by Gary Huber)
@@ -821,7 +1221,10 @@ Bug fixes:
 - PR#7135: only warn about ground coercions in -principal mode
   (Jacques Garrigue, report by Jeremy Yallop)
 
-- PR#7152: Typing equality involving non-generalizable type variable
+* PR#7152: Typing equality involving non-generalizable type variable
+  A side-effect of the fix is that, for deeply nested non generalizable
+  type variables, having an interface file may no longer be sufficient,
+  and you may have to add a local type annotation (cf PR#7313)
   (Jacques Garrigue, report by François Bobot)
 
 - PR#7160: Type synonym definitions can weaken gadt constructor types
@@ -851,6 +1254,13 @@ Bug fixes:
 - PR#7234: Compatibility check wrong for abstract type constructors
   (Jacques Garrigue, report by Stephen Dolan)
 
+- PR#7324: OCaml 4.03.0 type checker dies with an assert failure when
+  given some cyclic recusive module expression
+  (Jacques Garrigue, report by jmcarthur)
+
+- PR#7368: Manual major GC fails to compact the heap
+  (Krzysztof Pszeniczny)
+
 - GPR#205: Clear caml_backtrace_last_exn before registering as root
   (report and fix by Frederic Bour)
 
@@ -902,8 +1312,7 @@ Bug fixes:
   variant and arrow types
   (Thomas Refis)
 
-Features wishes:
-================
+### Features wishes:
 
 - PR#4518, GPR#29: change location format for reporting errors in ocamldoc
   (Sergei Lebedev)
@@ -1030,8 +1439,7 @@ Features wishes:
   (Mark Shinwell, debugging & test case by Arseniy Alekseyev and Leo White,
     code review by Xavier Leroy)
 
-Build system:
-=============
+### Build system:
 
 - GPR#388: FlexDLL added as a Git submodule and bootstrappable with the compiler
   (David Allsopp)

diff --git a/LICENSE b/LICENSE
index 515f12e7f0375733348937420168a324f3fc6ebf..3666ebe155665210b1d8478e788aa3f3e327d39e 100644 (file)
--- a/LICENSE
+++ b/LICENSE
@@ -1,627 +1,203 @@
-In the following, "the Library" refers to all files marked "Copyright
-INRIA" in the following directories and their sub-directories:
-
-  asmrun, byterun, config, otherlibs, stdlib, win32caml
-
-and "the Compiler" refers to all files marked "Copyright INRIA" in the
-following directories and their sub-directories:
-
-  asmcomp, boot, build, bytecomp, debugger, driver, lex, man,
-  ocamldoc, parsing, testsuite, tools, toplevel, typing,
-  utils, yacc
-
-The Compiler is distributed under the terms of the Q Public License
-version 1.0 with a change to choice of law (included below).
-
-The Library is distributed under the terms of the GNU Library General
-Public License version 2 (included below).
-
-As a special exception to the Q Public Licence, you may develop
-application programs, reusable components and other software items
-that link with the original or modified versions of the Compiler
-and are not made available to the general public, without any of the
-additional requirements listed in clause 6c of the Q Public licence.
-
-As a special exception to the GNU Library General Public License, you
-may link, statically or dynamically, a "work that uses the Library"
-with a publicly distributed version of the Library to produce an
-executable file containing portions of the Library, and distribute
-that executable file under terms of your choice, without any of the
-additional requirements listed in clause 6 of the GNU Library General
-Public License.  By "a publicly distributed version of the Library",
-we mean either the unmodified Library as distributed by INRIA, or a
-modified version of the Library that is distributed under the
-conditions defined in clause 2 of the GNU Library General Public
-License.  This exception does not however invalidate any other reasons
-why the executable file might be covered by the GNU Library General
-Public License.
+In the following, "the OCaml Core System" refers to all files marked
+"Copyright INRIA" in this distribution.
+
+The OCaml Core System is distributed under the terms of the
+GNU Lesser General Public License (LGPL) version 2.1 (included below).
+
+As a special exception to the GNU Lesser General Public License, you
+may link, statically or dynamically, a "work that uses the OCaml Core
+System" with a publicly distributed version of the OCaml Core System
+to produce an executable file containing portions of the OCaml Core
+System, and distribute that executable file under terms of your
+choice, without any of the additional requirements listed in clause 6
+of the GNU Lesser General Public License.  By "a publicly distributed
+version of the OCaml Core System", we mean either the unmodified OCaml
+Core System as distributed by INRIA, or a modified version of the
+OCaml Core System that is distributed under the conditions defined in
+clause 2 of the GNU Lesser General Public License.  This exception
+does not however invalidate any other reasons why the executable file
+might be covered by the GNU Lesser General Public License.
 
 ----------------------------------------------------------------------
 
-                   THE Q PUBLIC LICENSE version 1.0
+GNU LESSER GENERAL PUBLIC LICENSE
 
-              Copyright (C) 1999 Troll Tech AS, Norway.
-                  Everyone is permitted to copy and
-                  distribute this license document.
+Version 2.1, February 1999
 
-The intent of this license is to establish freedom to share and change
-the software regulated by this license under the open source model.
+Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
 
-This license applies to any software containing a notice placed by the
-copyright holder saying that it may be distributed under the terms of
-the Q Public License version 1.0. Such software is herein referred to
-as the Software. This license covers modification and distribution of
-the Software, use of third-party application programs based on the
-Software, and development of free software which uses the Software.
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
 
-                            Granted Rights
+Preamble
 
-1. You are granted the non-exclusive rights set forth in this license
-provided you agree to and comply with any and all conditions in this
-license. Whole or partial distribution of the Software, or software
-items that link with the Software, in any form signifies acceptance of
-this license.
+The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users.
 
-2. You may copy and distribute the Software in unmodified form
-provided that the entire package, including - but not restricted to -
-copyright, trademark notices and disclaimers, as released by the
-initial developer of the Software, is distributed.
+This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below.
 
-3. You may make modifications to the Software and distribute your
-modifications, in a form that is separate from the Software, such as
-patches. The following restrictions apply to modifications:
+When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things.
 
-      a. Modifications must not alter or remove any copyright notices
-      in the Software.
+To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it.
 
-      b. When modifications to the Software are released under this
-      license, a non-exclusive royalty-free right is granted to the
-      initial developer of the Software to distribute your
-      modification in future versions of the Software provided such
-      versions remain available under these terms in addition to any
-      other license(s) of the initial developer.
+For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights.
 
-4. You may distribute machine-executable forms of the Software or
-machine-executable forms of modified versions of the Software,
-provided that you meet these restrictions:
+We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library.
 
-      a. You must include this license document in the distribution.
+To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others.
 
-      b. You must ensure that all recipients of the machine-executable
-      forms are also able to receive the complete machine-readable
-      source code to the distributed Software, including all
-      modifications, without any charge beyond the costs of data
-      transfer, and place prominent notices in the distribution
-      explaining this.
+Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license.
 
-      c. You must ensure that all modifications included in the
-      machine-executable forms are available under the terms of this
-      license.
+Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs.
 
-5. You may use the original or modified versions of the Software to
-compile, link and run application programs legally developed by you or
-by others.
+When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library.
 
-6. You may develop application programs, reusable components and other
-software items that link with the original or modified versions of the
-Software. These items, when distributed, are subject to the following
-requirements:
+We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances.
 
-      a. You must ensure that all recipients of machine-executable
-      forms of these items are also able to receive and use the
-      complete machine-readable source code to the items without any
-      charge beyond the costs of data transfer.
+For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License.
 
-      b. You must explicitly license all recipients of your items to
-      use and re-distribute original and modified versions of the
-      items in both machine-executable and source code forms. The
-      recipients must be able to do so without any charges whatsoever,
-      and they must be able to re-distribute to anyone they choose.
+In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system.
 
-      c. If the items are not available to the general public, and the
-      initial developer of the Software requests a copy of the items,
-      then you must supply one.
+Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library.
 
-                       Limitations of Liability
+The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run.
 
-In no event shall the initial developers or copyright holders be
-liable for any damages whatsoever, including - but not restricted to -
-lost revenue or profits or other direct, indirect, special, incidental
-or consequential damages, even if they have been advised of the
-possibility of such damages, except to the extent invariable law, if
-any, provides otherwise.
+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
 
-                             No Warranty
+0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you".
 
-The Software and this license document are provided AS IS with NO
-WARRANTY OF ANY KIND, INCLUDING THE WARRANTY OF DESIGN,
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables.
 
-                            Choice of Law
+The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".)
 
-This license is governed by the Laws of France.
+"Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library.
 
-----------------------------------------------------------------------
+Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does.
+
+1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library.
+
+You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.
 
-                  GNU LIBRARY GENERAL PUBLIC LICENSE
-                       Version 2, June 1991
-
- Copyright (C) 1991 Free Software Foundation, Inc.
- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-[This is the first released version of the library GPL.  It is
- numbered 2 because it goes with version 2 of the ordinary GPL.]
-
-                            Preamble
-
-  The licenses for most software are designed to take away your
-freedom to share and change it.  By contrast, the GNU General Public
-Licenses are intended to guarantee your freedom to share and change
-free software--to make sure the software is free for all its users.
-
-  This license, the Library General Public License, applies to some
-specially designated Free Software Foundation software, and to any
-other libraries whose authors decide to use it.  You can use it for
-your libraries, too.
-
-  When we speak of free software, we are referring to freedom, not
-price.  Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
-  To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if
-you distribute copies of the library, or if you modify it.
-
-  For example, if you distribute copies of the library, whether gratis
-or for a fee, you must give the recipients all the rights that we gave
-you.  You must make sure that they, too, receive or can get the source
-code.  If you link a program with the library, you must provide
-complete object files to the recipients so that they can relink them
-with the library, after making changes to the library and recompiling
-it.  And you must show them these terms so they know their rights.
-
-  Our method of protecting your rights has two steps: (1) copyright
-the library, and (2) offer you this license which gives you legal
-permission to copy, distribute and/or modify the library.
-
-  Also, for each distributor's protection, we want to make certain
-that everyone understands that there is no warranty for this free
-library.  If the library is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original
-version, so that any problems introduced by others will not reflect on
-the original authors' reputations.
-\f
-  Finally, any free program is threatened constantly by software
-patents.  We wish to avoid the danger that companies distributing free
-software will individually obtain patent licenses, thus in effect
-transforming the program into proprietary software.  To prevent this,
-we have made it clear that any patent must be licensed for everyone's
-free use or not licensed at all.
-
-  Most GNU software, including some libraries, is covered by the ordinary
-GNU General Public License, which was designed for utility programs.  This
-license, the GNU Library General Public License, applies to certain
-designated libraries.  This license is quite different from the ordinary
-one; be sure to read it in full, and don't assume that anything in it is
-the same as in the ordinary license.
-
-  The reason we have a separate public license for some libraries is that
-they blur the distinction we usually make between modifying or adding to a
-program and simply using it.  Linking a program with a library, without
-changing the library, is in some sense simply using the library, and is
-analogous to running a utility program or application program.  However, in
-a textual and legal sense, the linked executable is a combined work, a
-derivative of the original library, and the ordinary General Public License
-treats it as such.
-
-  Because of this blurred distinction, using the ordinary General
-Public License for libraries did not effectively promote software
-sharing, because most developers did not use the libraries.  We
-concluded that weaker conditions might promote sharing better.
-
-  However, unrestricted linking of non-free programs would deprive the
-users of those programs of all benefit from the free status of the
-libraries themselves.  This Library General Public License is intended to
-permit developers of non-free programs to use free libraries, while
-preserving your freedom as a user of such programs to change the free
-libraries that are incorporated in them.  (We have not seen how to achieve
-this as regards changes in header files, but we have achieved it as regards
-changes in the actual functions of the Library.)  The hope is that this
-will lead to faster development of free libraries.
-
-  The precise terms and conditions for copying, distribution and
-modification follow.  Pay close attention to the difference between a
-"work based on the library" and a "work that uses the library".  The
-former contains code derived from the library, while the latter only
-works together with the library.
-
-  Note that it is possible for a library to be covered by the ordinary
-General Public License rather than by this special one.
-\f
-                  GNU LIBRARY GENERAL PUBLIC LICENSE
-   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
-  0. This License Agreement applies to any software library which
-contains a notice placed by the copyright holder or other authorized
-party saying it may be distributed under the terms of this Library
-General Public License (also called "this License").  Each licensee is
-addressed as "you".
-
-  A "library" means a collection of software functions and/or data
-prepared so as to be conveniently linked with application programs
-(which use some of those functions and data) to form executables.
-
-  The "Library", below, refers to any such software library or work
-which has been distributed under these terms.  A "work based on the
-Library" means either the Library or any derivative work under
-copyright law: that is to say, a work containing the Library or a
-portion of it, either verbatim or with modifications and/or translated
-straightforwardly into another language.  (Hereinafter, translation is
-included without limitation in the term "modification".)
-
-  "Source code" for a work means the preferred form of the work for
-making modifications to it.  For a library, complete source code means
-all the source code for all modules it contains, plus any associated
-interface definition files, plus the scripts used to control compilation
-and installation of the library.
-
-  Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope.  The act of
-running a program using the Library is not restricted, and output from
-such a program is covered only if its contents constitute a work based
-on the Library (independent of the use of the Library in a tool for
-writing it).  Whether that is true depends on what the Library does
-and what the program that uses the Library does.
-
-  1. You may copy and distribute verbatim copies of the Library's
-complete source code as you receive it, in any medium, provided that
-you conspicuously and appropriately publish on each copy an
-appropriate copyright notice and disclaimer of warranty; keep intact
-all the notices that refer to this License and to the absence of any
-warranty; and distribute a copy of this License along with the
-Library.
-
-  You may charge a fee for the physical act of transferring a copy,
-and you may at your option offer warranty protection in exchange for a
-fee.
-\f
-  2. You may modify your copy or copies of the Library or any portion
-of it, thus forming a work based on the Library, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
+2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions:
 
     a) The modified work must itself be a software library.
+    b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change.
+    c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License.
+    d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful.
+
+    (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License.
+
+3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices.
+
+Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy.
+
+This option is useful when you wish to copy part of the code of the Library into a program that is not a library.
+
+4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange.
+
+If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code.
+
+5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License.
+
+However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables.
+
+When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law.
+
+If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.)
+
+Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself.
+
+6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications.
+
+You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things:
+
+    a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.)
+    b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with.
+    c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution.
+    d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place.
+    e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy.
+
+For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable.
+
+It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute.
+
+7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things:
 
-    b) You must cause the files modified to carry prominent notices
-    stating that you changed the files and the date of any change.
-
-    c) You must cause the whole of the work to be licensed at no
-    charge to all third parties under the terms of this License.
-
-    d) If a facility in the modified Library refers to a function or a
-    table of data to be supplied by an application program that uses
-    the facility, other than as an argument passed when the facility
-    is invoked, then you must make a good faith effort to ensure that,
-    in the event an application does not supply such function or
-    table, the facility still operates, and performs whatever part of
-    its purpose remains meaningful.
-
-    (For example, a function in a library to compute square roots has
-    a purpose that is entirely well-defined independent of the
-    application.  Therefore, Subsection 2d requires that any
-    application-supplied function or table used by this function must
-    be optional: if the application does not supply it, the square
-    root function must still compute square roots.)
-
-These requirements apply to the modified work as a whole.  If
-identifiable sections of that work are not derived from the Library,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works.  But when you
-distribute the same sections as part of a whole which is a work based
-on the Library, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote
-it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Library.
-
-In addition, mere aggregation of another work not based on the Library
-with the Library (or with a work based on the Library) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
-  3. You may opt to apply the terms of the ordinary GNU General Public
-License instead of this License to a given copy of the Library.  To do
-this, you must alter all the notices that refer to this License, so
-that they refer to the ordinary GNU General Public License, version 2,
-instead of to this License.  (If a newer version than version 2 of the
-ordinary GNU General Public License has appeared, then you can specify
-that version instead if you wish.)  Do not make any other change in
-these notices.
-\f
-  Once this change is made in a given copy, it is irreversible for
-that copy, so the ordinary GNU General Public License applies to all
-subsequent copies and derivative works made from that copy.
-
-  This option is useful when you wish to copy part of the code of
-the Library into a program that is not a library.
-
-  4. You may copy and distribute the Library (or a portion or
-derivative of it, under Section 2) in object code or executable form
-under the terms of Sections 1 and 2 above provided that you accompany
-it with the complete corresponding machine-readable source code, which
-must be distributed under the terms of Sections 1 and 2 above on a
-medium customarily used for software interchange.
-
-  If distribution of object code is made by offering access to copy
-from a designated place, then offering equivalent access to copy the
-source code from the same place satisfies the requirement to
-distribute the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
-  5. A program that contains no derivative of any portion of the
-Library, but is designed to work with the Library by being compiled or
-linked with it, is called a "work that uses the Library".  Such a
-work, in isolation, is not a derivative work of the Library, and
-therefore falls outside the scope of this License.
-
-  However, linking a "work that uses the Library" with the Library
-creates an executable that is a derivative of the Library (because it
-contains portions of the Library), rather than a "work that uses the
-library".  The executable is therefore covered by this License.
-Section 6 states terms for distribution of such executables.
-
-  When a "work that uses the Library" uses material from a header file
-that is part of the Library, the object code for the work may be a
-derivative work of the Library even though the source code is not.
-Whether this is true is especially significant if the work can be
-linked without the Library, or if the work is itself a library.  The
-threshold for this to be true is not precisely defined by law.
-
-  If such an object file uses only numerical parameters, data
-structure layouts and accessors, and small macros and small inline
-functions (ten lines or less in length), then the use of the object
-file is unrestricted, regardless of whether it is legally a derivative
-work.  (Executables containing this object code plus portions of the
-Library will still fall under Section 6.)
-
-  Otherwise, if the work is a derivative of the Library, you may
-distribute the object code for the work under the terms of Section 6.
-Any executables containing that work also fall under Section 6,
-whether or not they are linked directly with the Library itself.
-\f
-  6. As an exception to the Sections above, you may also compile or
-link a "work that uses the Library" with the Library to produce a
-work containing portions of the Library, and distribute that work
-under terms of your choice, provided that the terms permit
-modification of the work for the customer's own use and reverse
-engineering for debugging such modifications.
-
-  You must give prominent notice with each copy of the work that the
-Library is used in it and that the Library and its use are covered by
-this License.  You must supply a copy of this License.  If the work
-during execution displays copyright notices, you must include the
-copyright notice for the Library among them, as well as a reference
-directing the user to the copy of this License.  Also, you must do one
-of these things:
-
-    a) Accompany the work with the complete corresponding
-    machine-readable source code for the Library including whatever
-    changes were used in the work (which must be distributed under
-    Sections 1 and 2 above); and, if the work is an executable linked
-    with the Library, with the complete machine-readable "work that
-    uses the Library", as object code and/or source code, so that the
-    user can modify the Library and then relink to produce a modified
-    executable containing the modified Library.  (It is understood
-    that the user who changes the contents of definitions files in the
-    Library will not necessarily be able to recompile the application
-    to use the modified definitions.)
-
-    b) Accompany the work with a written offer, valid for at
-    least three years, to give the same user the materials
-    specified in Subsection 6a, above, for a charge no more
-    than the cost of performing this distribution.
-
-    c) If distribution of the work is made by offering access to copy
-    from a designated place, offer equivalent access to copy the above
-    specified materials from the same place.
-
-    d) Verify that the user has already received a copy of these
-    materials or that you have already sent this user a copy.
-
-  For an executable, the required form of the "work that uses the
-Library" must include any data and utility programs needed for
-reproducing the executable from it.  However, as a special exception,
-the source code distributed need not include anything that is normally
-distributed (in either source or binary form) with the major
-components (compiler, kernel, and so on) of the operating system on
-which the executable runs, unless that component itself accompanies
-the executable.
-
-  It may happen that this requirement contradicts the license
-restrictions of other proprietary libraries that do not normally
-accompany the operating system.  Such a contradiction means you cannot
-use both them and the Library together in an executable that you
-distribute.
-\f
-  7. You may place library facilities that are a work based on the
-Library side-by-side in a single library together with other library
-facilities not covered by this License, and distribute such a combined
-library, provided that the separate distribution of the work based on
-the Library and of the other library facilities is otherwise
-permitted, and provided that you do these two things:
-
-    a) Accompany the combined library with a copy of the same work
-    based on the Library, uncombined with any other library
-    facilities.  This must be distributed under the terms of the
-    Sections above.
-
-    b) Give prominent notice with the combined library of the fact
-    that part of it is a work based on the Library, and explaining
-    where to find the accompanying uncombined form of the same work.
-
-  8. You may not copy, modify, sublicense, link with, or distribute
-the Library except as expressly provided under this License.  Any
-attempt otherwise to copy, modify, sublicense, link with, or
-distribute the Library is void, and will automatically terminate your
-rights under this License.  However, parties who have received copies,
-or rights, from you under this License will not have their licenses
-terminated so long as such parties remain in full compliance.
-
-  9. You are not required to accept this License, since you have not
-signed it.  However, nothing else grants you permission to modify or
-distribute the Library or its derivative works.  These actions are
-prohibited by law if you do not accept this License.  Therefore, by
-modifying or distributing the Library (or any work based on the
-Library), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Library or works based on it.
-
-  10. Each time you redistribute the Library (or any work based on the
-Library), the recipient automatically receives a license from the
-original licensor to copy, distribute, link with or modify the Library
-subject to these terms and conditions.  You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-\f
-  11. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License.  If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Library at all.  For example, if a patent
-license would not permit royalty-free redistribution of the Library by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Library.
-
-If any portion of this section is held invalid or unenforceable under any
-particular circumstance, the balance of the section is intended to apply,
-and the section as a whole is intended to apply in other circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system which is
-implemented by public license practices.  Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
-  12. If the distribution and/or use of the Library is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Library under this License may add
-an explicit geographical distribution limitation excluding those countries,
-so that distribution is permitted only in or among countries not thus
-excluded.  In such case, this License incorporates the limitation as if
-written in the body of this License.
-
-  13. The Free Software Foundation may publish revised and/or new
-versions of the Library General Public License from time to time.
-Such new versions will be similar in spirit to the present version,
-but may differ in detail to address new problems or concerns.
-
-Each version is given a distinguishing version number.  If the Library
-specifies a version number of this License which applies to it and
-"any later version", you have the option of following the terms and
-conditions either of that version or of any later version published by
-the Free Software Foundation.  If the Library does not specify a
-license version number, you may choose any version ever published by
-the Free Software Foundation.
-\f
-  14. If you wish to incorporate parts of the Library into other free
-programs whose distribution conditions are incompatible with these,
-write to the author to ask for permission.  For software which is
-copyrighted by the Free Software Foundation, write to the Free
-Software Foundation; we sometimes make exceptions for this.  Our
-decision will be guided by the two goals of preserving the free status
-of all derivatives of our free software and of promoting the sharing
-and reuse of software generally.
-
-                            NO WARRANTY
-
-  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
-WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
-EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
-OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
-KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
-LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
-THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
-  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
-WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
-AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
-FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
-CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
-LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
-RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
-FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
-SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
-DAMAGES.
-
-                     END OF TERMS AND CONDITIONS
-\f
-     Appendix: How to Apply These Terms to Your New Libraries
-
-  If you develop a new library, and you want it to be of the greatest
-possible use to the public, we recommend making it free software that
-everyone can redistribute and change.  You can do so by permitting
-redistribution under these terms (or, alternatively, under the terms of the
-ordinary General Public License).
-
-  To apply these terms, attach the following notices to the library.  It is
-safest to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least the
-"copyright" line and a pointer to where the full notice is found.
-
-    <one line to give the library's name and a brief idea of what it does.>
-    Copyright (C) <year>  <name of author>
-
-    This library is free software; you can redistribute it and/or
-    modify it under the terms of the GNU Library General Public
-    License as published by the Free Software Foundation; either
-    version 2 of the License, or (at your option) any later version.
-
-    This library is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-    Library General Public License for more details.
-
-    You should have received a copy of the GNU Library General Public
-    License along with this library; if not, write to the Free
-    Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
-    MA 02111-1307, USA
+    a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above.
+    b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work.
+
+8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance.
+
+9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it.
+
+10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License.
+
+11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice.
+
+This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License.
+
+12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License.
+
+13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation.
+
+14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally.
+
+NO WARRANTY
+
+15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+END OF TERMS AND CONDITIONS
+
+How to Apply These Terms to Your New Libraries
+
+If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License).
+
+To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found.
+
+one line to give the library's name and an idea of what it does.
+Copyright (C) year  name of author
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 
 Also add information on how to contact you by electronic and paper mail.
 
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the library, if
-necessary.  Here is a sample; alter the names:
+You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names:
 
-  Yoyodyne, Inc., hereby disclaims all copyright interest in the
-  library `Frob' (a library for tweaking knobs) written by James Random Hacker.
+Yoyodyne, Inc., hereby disclaims all copyright interest in
+the library `Frob' (a library for tweaking knobs) written
+by James Random Hacker.
 
-  <signature of Ty Coon>, 1 April 1990
-  Ty Coon, President of Vice
+signature of Ty Coon, 1 April 1990
+Ty Coon, President of Vice
 
 That's all there is to it!
+
+--------------------------------------------------

diff --git a/Makefile b/Makefile
index 75c7973b6b0d808035c65e3559a45f770d7d022d..85be2db2abd9fc63f12d927a51e7dcd851ec5bb4 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -48,6 +48,9 @@ world.opt:
        $(MAKE) coldstart
        $(MAKE) opt.opt
 
+reconfigure:
+       ./configure $(CONFIGURE_ARGS)
+
 # Hard bootstrap how-to:
 # (only necessary in some cases, for example if you remove some primitive)
 #
@@ -95,7 +98,8 @@ coldstart:
        cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
        cd yacc; $(MAKE) all
        cp yacc/ocamlyacc$(EXE) boot/ocamlyacc$(EXE)
-       cd stdlib; $(MAKE) COMPILER=../boot/ocamlc all
+       cd stdlib; \
+         $(MAKE) COMPILER="../boot/ocamlc -use-prims ../byterun/primitives" all
        cd stdlib; cp $(LIBFILES) ../boot
        if test -f boot/libcamlrun.a; then :; else \
          ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi
@@ -220,10 +224,10 @@ install:
          dllbigarray$(EXT_DLL) dllnums$(EXT_DLL) dllthreads$(EXT_DLL) \
          dllunix$(EXT_DLL) dllgraphics$(EXT_DLL) dllstr$(EXT_DLL)
        cd byterun; $(MAKE) install
-       cp ocamlc $(INSTALL_BINDIR)/ocamlc$(EXE)
+       cp ocamlc $(INSTALL_BINDIR)/ocamlc.byte$(EXE)
        cp ocaml $(INSTALL_BINDIR)/ocaml$(EXE)
        cd stdlib; $(MAKE) install
-       cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex$(EXE)
+       cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex.byte$(EXE)
        cp $(CAMLYACC)$(EXE) $(INSTALL_BINDIR)/ocamlyacc$(EXE)
        cp utils/*.cmi utils/*.cmt utils/*.cmti \
           parsing/*.cmi parsing/*.cmt parsing/*.cmti \
@@ -244,12 +248,16 @@ install:
        if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) install); fi
        if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKE) install); fi
        cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config
-       if test -f ocamlopt; then $(MAKE) installopt; fi
+       if test -f ocamlopt; then $(MAKE) installopt; else \
+          cd $(INSTALL_BINDIR); \
+          ln -sf ocamlc.byte$(EXE) ocamlc$(EXE); \
+          ln -sf ocamllex.byte$(EXE) ocamllex$(EXE); \
+          fi
 
 # Installation of the native-code compiler
 installopt:
        cd asmrun; $(MAKE) install
-       cp ocamlopt $(INSTALL_BINDIR)/ocamlopt$(EXE)
+       cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.byte$(EXE)
        cd stdlib; $(MAKE) installopt
        cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \
                $(INSTALL_COMPLIBDIR)
@@ -261,13 +269,18 @@ installopt:
                else :; fi
        for i in $(OTHERLIBRARIES); \
          do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done
-       if test -f ocamlopt.opt ; then $(MAKE) installoptopt; fi
+       if test -f ocamlopt.opt ; then $(MAKE) installoptopt; else \
+          cd $(INSTALL_BINDIR); ln -sf ocamlopt.byte$(EXE) ocamlopt$(EXE); fi
        cd tools; $(MAKE) installopt
 
 installoptopt:
        cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE)
        cp ocamlopt.opt $(INSTALL_BINDIR)/ocamlopt.opt$(EXE)
        cp lex/ocamllex.opt $(INSTALL_BINDIR)/ocamllex.opt$(EXE)
+       cd $(INSTALL_BINDIR); \
+          ln -sf ocamlc.opt$(EXE) ocamlc$(EXE); \
+          ln -sf ocamlopt.opt$(EXE) ocamlopt$(EXE); \
+          ln -sf ocamllex.opt$(EXE) ocamllex$(EXE)
        cp utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \
            driver/*.cmx asmcomp/*.cmx $(INSTALL_COMPLIBDIR)
        cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \
@@ -323,9 +336,11 @@ compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP)
 partialclean::
        rm -f compilerlibs/ocamloptcomp.cma
 
-ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART)
+ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
+          compilerlibs/ocamlbytecomp.cma $(OPTSTART)
        $(CAMLC) $(LINKFLAGS) -o ocamlopt \
-         compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART)
+         compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
+         compilerlibs/ocamlbytecomp.cma $(OPTSTART)
 
 partialclean::
        rm -f ocamlopt
@@ -372,12 +387,10 @@ partialclean::
        rm -f compilerlibs/ocamlopttoplevel.cmxa
 
 ocamlnat: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
-    otherlibs/dynlink/dynlink.cmxa compilerlibs/ocamlopttoplevel.cmxa \
+    compilerlibs/ocamlbytecomp.cmxa \
+    compilerlibs/ocamlopttoplevel.cmxa \
     $(OPTTOPLEVELSTART:.cmo=.cmx)
-       $(CAMLOPT) $(LINKFLAGS) -linkall -o ocamlnat \
-           otherlibs/dynlink/dynlink.cmxa compilerlibs/ocamlcommon.cmxa \
-           compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamlopttoplevel.cmxa \
-           $(OPTTOPLEVELSTART:.cmo=.cmx)
+       $(CAMLOPT) $(LINKFLAGS) -linkall -o $@ $^
 
 partialclean::
        rm -f ocamlnat
@@ -414,12 +427,17 @@ utils/config.ml: utils/config.mlp config/Makefile
            -e 's|%%ASM%%|$(ASM)|' \
            -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \
            -e 's|%%WITH_FRAME_POINTERS%%|$(WITH_FRAME_POINTERS)|' \
+           -e 's|%%WITH_SPACETIME%%|$(WITH_SPACETIME)|' \
+           -e 's|%%PROFINFO_WIDTH%%|$(PROFINFO_WIDTH)|' \
+           -e 's|%%LIBUNWIND_AVAILABLE%%|$(LIBUNWIND_AVAILABLE)|' \
+           -e 's|%%LIBUNWIND_LINK_FLAGS%%|$(LIBUNWIND_LINK_FLAGS)|' \
            -e 's|%%MKDLL%%|$(MKDLL)|' \
            -e 's|%%MKEXE%%|$(MKEXE)|' \
            -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
            -e 's|%%HOST%%|$(HOST)|' \
            -e 's|%%TARGET%%|$(TARGET)|' \
            -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \
+           -e 's|%%SAFE_STRING%%|$(SAFE_STRING)|' \
            utils/config.mlp > utils/config.ml
 
 partialclean::
@@ -478,9 +496,11 @@ partialclean::
        rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a
 
 ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+              compilerlibs/ocamlbytecomp.cmxa  \
               $(OPTSTART:.cmo=.cmx)
        $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \
           compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+          compilerlibs/ocamlbytecomp.cmxa  \
           $(OPTSTART:.cmo=.cmx)
 
 partialclean::
@@ -521,66 +541,32 @@ beforedepend:: bytecomp/runtimedef.ml
 
 # Choose the right machine-dependent files
 
-asmcomp/arch.ml: asmcomp/$(ARCH)/arch.ml
-       ln -s $(ARCH)/arch.ml asmcomp/arch.ml
-
-partialclean::
-       rm -f asmcomp/arch.ml
-
-beforedepend:: asmcomp/arch.ml
-
-asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml
-       ln -s $(ARCH)/proc.ml asmcomp/proc.ml
-
-partialclean::
-       rm -f asmcomp/proc.ml
-
-beforedepend:: asmcomp/proc.ml
-
-asmcomp/selection.ml: asmcomp/$(ARCH)/selection.ml
-       ln -s $(ARCH)/selection.ml asmcomp/selection.ml
-
-partialclean::
-       rm -f asmcomp/selection.ml
-
-beforedepend:: asmcomp/selection.ml
-
-asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml
-       ln -s $(ARCH)/CSE.ml asmcomp/CSE.ml
-
-partialclean::
-       rm -f asmcomp/CSE.ml
+asmcomp/arch.ml: asmcomp/$(ARCH_OCAMLOPT)/arch.ml
+       ln -s $(ARCH_OCAMLOPT)/arch.ml asmcomp/arch.ml
 
-beforedepend:: asmcomp/CSE.ml
+asmcomp/proc.ml: asmcomp/$(ARCH_OCAMLOPT)/proc.ml
+       ln -s $(ARCH_OCAMLOPT)/proc.ml asmcomp/proc.ml
 
-asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml
-       ln -s $(ARCH)/reload.ml asmcomp/reload.ml
+asmcomp/selection.ml: asmcomp/$(ARCH_OCAMLOPT)/selection.ml
+       ln -s $(ARCH_OCAMLOPT)/selection.ml asmcomp/selection.ml
 
-partialclean::
-       rm -f asmcomp/reload.ml
+asmcomp/CSE.ml: asmcomp/$(ARCH_OCAMLOPT)/CSE.ml
+       ln -s $(ARCH_OCAMLOPT)/CSE.ml asmcomp/CSE.ml
 
-beforedepend:: asmcomp/reload.ml
+asmcomp/reload.ml: asmcomp/$(ARCH_OCAMLOPT)/reload.ml
+       ln -s $(ARCH_OCAMLOPT)/reload.ml asmcomp/reload.ml
 
-asmcomp/scheduling.ml: asmcomp/$(ARCH)/scheduling.ml
-       ln -s $(ARCH)/scheduling.ml asmcomp/scheduling.ml
-
-partialclean::
-       rm -f asmcomp/scheduling.ml
-
-beforedepend:: asmcomp/scheduling.ml
+asmcomp/scheduling.ml: asmcomp/$(ARCH_OCAMLOPT)/scheduling.ml
+       ln -s $(ARCH_OCAMLOPT)/scheduling.ml asmcomp/scheduling.ml
 
 # Preprocess the code emitters
 
-asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit
-       echo \# 1 \"$(ARCH)/emit.mlp\" > asmcomp/emit.ml
-       $(CAMLRUN) tools/cvt_emit <asmcomp/$(ARCH)/emit.mlp >>asmcomp/emit.ml \
+asmcomp/emit.ml: asmcomp/$(ARCH_OCAMLOPT)/emit.mlp tools/cvt_emit
+       echo \# 1 \"$(ARCH_OCAMLOPT)/emit.mlp\" > asmcomp/emit.ml
+       $(CAMLRUN) tools/cvt_emit <asmcomp/$(ARCH_OCAMLOPT)/emit.mlp \
+                                 >>asmcomp/emit.ml \
        || { rm -f asmcomp/emit.ml; exit 2; }
 
-partialclean::
-       rm -f asmcomp/emit.ml
-
-beforedepend:: asmcomp/emit.ml
-
 tools/cvt_emit: tools/cvt_emit.mll
        cd tools && $(MAKE) cvt_emit
 
@@ -764,6 +750,10 @@ depend: beforedepend
         middle_end/base_types driver toplevel; \
         do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
         done) > .depend
+       $(CAMLDEP) $(DEPFLAGS) -native \
+               -impl driver/compdynlink.mlopt >> .depend
+       $(CAMLDEP) $(DEPFLAGS) -bytecode \
+               -impl driver/compdynlink.mlbyte >> .depend
 
 alldepend:: depend
 

diff --git a/Makefile.nt b/Makefile.nt
index 079fca74b48751bbb3e6c87697da9d0614ef6aaf..4207c996af93040fd371dc2f149160d8d5c39159 100644 (file)
--- a/Makefile.nt
+++ b/Makefile.nt
@@ -115,7 +115,10 @@ coldstart:
        cp byterun/ocamlrun.exe boot/ocamlrun.exe
        cd yacc ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
        cp yacc/ocamlyacc.exe boot/ocamlyacc.exe
-       cd stdlib ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) COMPILER=../boot/ocamlc all
+       cd stdlib ; \
+         $(MAKEREC) $(BOOT_FLEXLINK_CMD) \
+                    COMPILER="../boot/ocamlc -use-prims ../byterun/primitives"\
+                    all
        cd stdlib ; cp $(LIBFILES) ../boot
 
 # Build the core system: the minimum needed to make depend and bootstrap
@@ -207,9 +210,11 @@ installbyt:
        cd byterun ; $(MAKEREC) install
        cp ocamlc "$(INSTALL_BINDIR)/ocamlc.exe"
        cp ocaml "$(INSTALL_BINDIR)/ocaml.exe"
+       cp ocamlc "$(INSTALL_BINDIR)/ocamlc.byte.exe"
        cd stdlib ; $(MAKEREC) install
        cp lex/ocamllex "$(INSTALL_BINDIR)/ocamllex.exe"
        cp yacc/ocamlyacc.exe "$(INSTALL_BINDIR)/ocamlyacc.exe"
+       cp lex/ocamllex "$(INSTALL_BINDIR)/ocamllex.byte.exe"
        cp utils/*.cmi utils/*.cmt utils/*.cmti \
           parsing/*.cmi parsing/*.cmt parsing/*.cmti \
           typing/*.cmi typing/*.cmt typing/*.cmti \
@@ -235,10 +240,12 @@ installbyt:
          $(MAKEREC) install-flexdll; \
        fi
        cp config/Makefile "$(INSTALL_LIBDIR)/Makefile.config"
-       cp README.adoc "$(INSTALL_DISTRIB)/Readme.general.txt"
-       cp README.win32.adoc "$(INSTALL_DISTRIB)/Readme.windows.txt"
-       cp LICENSE "$(INSTALL_DISTRIB)/License.txt"
-       cp Changes "$(INSTALL_DISTRIB)/Changes.txt"
+       if test -n "$(INSTALL_DISTRIB)"; then \
+          cp README.adoc "$(INSTALL_DISTRIB)/Readme.general.txt"; \
+          cp README.win32.adoc "$(INSTALL_DISTRIB)/Readme.windows.txt"; \
+          cp LICENSE "$(INSTALL_DISTRIB)/License.txt"; \
+          cp Changes "$(INSTALL_DISTRIB)/Changes.txt"; \
+       fi
 
 install-flexdll:
 # The $(if ...) installs the correct .manifest file for MSVC and MSVC64
@@ -254,6 +261,7 @@ install-flexdll:
 installopt:
        cd asmrun && $(MAKEREC) install
        cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.exe"
+       cp ocamlopt "$(INSTALL_BINDIR)/ocamlopt.byte.exe"
        cd stdlib && $(MAKEREC) installopt
        cp middle_end/*.cmi middle_end/*.cmt middle_end/*.cmti \
                "$(INSTALL_COMPLIBDIR)"
@@ -277,6 +285,9 @@ installoptopt:
        cp ocamlc.opt "$(INSTALL_BINDIR)/ocamlc.opt$(EXE)"
        cp ocamlopt.opt "$(INSTALL_BINDIR)/ocamlopt.opt$(EXE)"
        cp lex/ocamllex.opt "$(INSTALL_BINDIR)/ocamllex.opt$(EXE)"
+       cp ocamlc.opt "$(INSTALL_BINDIR)/ocamlc$(EXE)"
+       cp ocamlopt.opt "$(INSTALL_BINDIR)/ocamlopt$(EXE)"
+       cp lex/ocamllex.opt "$(INSTALL_BINDIR)/ocamllex$(EXE)"
        cp utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \
            driver/*.cmx asmcomp/*.cmx "$(INSTALL_COMPLIBDIR)"
        cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \
@@ -324,9 +335,11 @@ compilerlibs/ocamloptcomp.cma: $(MIDDLE_END) $(ASMCOMP)
 partialclean::
        rm -f compilerlibs/ocamloptcomp.cma
 
-ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART)
+ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
+          compilerlibs/ocamlbytecomp.cma $(OPTSTART)
        $(CAMLC) $(LINKFLAGS) -o ocamlopt \
-          compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART)
+          compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
+         compilerlibs/ocamlbytecomp.cma $(OPTSTART)
 
 partialclean::
        rm -f ocamlopt
@@ -351,9 +364,16 @@ partialclean::
 
 # The native toplevel
 
-ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx)
-       $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \
-                  $(NATTOPOBJS:.cmo=.cmx) -linkall
+compilerlibs/ocamlopttoplevel.cmxa: $(OPTTOPLEVEL:.cmo=.cmx)
+       $(CAMLOPT) -a -o $@ $(OPTTOPLEVEL:.cmo=.cmx)
+partialclean::
+       rm -f compilerlibs/ocamlopttoplevel.cmxa
+
+ocamlnat: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+    compilerlibs/ocamlbytecomp.cmxa \
+    compilerlibs/ocamlopttoplevel.cmxa \
+    $(OPTTOPLEVELSTART:.cmo=.cmx)
+       $(CAMLOPT) $(LINKFLAGS) -linkall -o $@ $^
 
 toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa
 
@@ -389,6 +409,10 @@ utils/config.ml: utils/config.mlp config/Makefile
            -e 's|%%ASM%%|$(ASM)|' \
            -e 's|%%ASM_CFI_SUPPORTED%%|false|' \
            -e 's|%%WITH_FRAME_POINTERS%%|false|' \
+           -e 's|%%WITH_SPACETIME%%|$(WITH_SPACETIME)|' \
+           -e 's|%%PROFINFO_WIDTH%%|$(PROFINFO_WIDTH)|' \
+           -e 's|%%LIBUNWIND_AVAILABLE%%|false|' \
+           -e 's|%%LIBUNWIND_LINK_FLAGS%%||' \
            -e 's|%%MKDLL%%|$(MKDLL)|' \
            -e 's|%%MKEXE%%|$(MKEXE)|' \
            -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
@@ -396,6 +420,7 @@ utils/config.ml: utils/config.mlp config/Makefile
            -e 's|%%HOST%%|$(HOST)|' \
            -e 's|%%TARGET%%|$(TARGET)|' \
            -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \
+           -e 's|%%SAFE_STRING%%|$(SAFE_STRING)|' \
            -e 's|%%FLEXLINK_FLAGS%%|$(FLEXLINK_FLAGS)|' \
            utils/config.mlp > utils/config.ml
 
@@ -455,10 +480,12 @@ partialclean::
        rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A)
 
 ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+              compilerlibs/ocamlbytecomp.cmxa \
               $(OPTSTART:.cmo=.cmx)
        $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \
-           compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
-           $(OPTSTART:.cmo=.cmx)
+          compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
+         compilerlibs/ocamlbytecomp.cmxa \
+          $(OPTSTART:.cmo=.cmx)
 
 partialclean::
        rm -f ocamlopt.opt
@@ -588,7 +615,7 @@ alldepend::
 runtimeopt: makeruntimeopt stdlib/libasmrun.$(A)
 
 makeruntimeopt:
-       cd asmrun ; $(MAKEREC) all
+       cd asmrun ; $(MAKEREC) $(BOOT_FLEXLINK_CMD) all
 stdlib/libasmrun.$(A): asmrun/libasmrun.$(A)
        cp asmrun/libasmrun.$(A) stdlib/libasmrun.$(A)
 clean::
@@ -704,14 +731,20 @@ partialclean::
 depend: beforedepend
        (for d in utils parsing typing bytecomp asmcomp middle_end \
         middle_end/base_types driver toplevel; \
-        do $(CAMLDEP) $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
+        do $(CAMLDEP) -slash $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
         done) > .depend
+       $(CAMLDEP) -slash $(DEPFLAGS) -native \
+               -impl driver/compdynlink.mlopt >> .depend
+       $(CAMLDEP) -slash $(DEPFLAGS) -bytecode \
+               -impl driver/compdynlink.mlbyte >> .depend
 
 alldepend:: depend
 
 distclean:
        $(MAKEREC) clean
-       rm -f asmrun/.depend.nt byterun/.depend.nt
+       rm -f asmrun/.depend.nt byterun/.depend.nt \
+                   otherlibs/bigarray/.depend.nt  \
+                   otherlibs/str/.depend.nt
        rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader boot/ocamlyacc \
              boot/*.cm* boot/libcamlrun.a
        rm -f config/Makefile config/m.h config/s.h

diff --git a/Makefile.shared b/Makefile.shared
index f79b63225e6719b92981121767ec4782afdf6391..5ffccb4aa893ea14a4e9b27b49ba592b7c8b3d63 100644 (file)
--- a/Makefile.shared
+++ b/Makefile.shared
@@ -17,19 +17,19 @@
 defaultentry:
 
 # The main Makefile, fragments shared between Makefile and Makefile.nt
-
 include config/Makefile
 CAMLRUN ?= boot/ocamlrun
 CAMLYACC ?= boot/ocamlyacc
 include stdlib/StdlibModules
 
-CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot
+CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot -use-prims byterun/primitives
 CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
-COMPFLAGS=-strict-sequence -principal -w +33..39+48+50 -warn-error A \
+COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48 \
+         -warn-error A \
           -bin-annot -safe-string -strict-formats $(INCLUDES)
 LINKFLAGS=
 
-YACCFLAGS=-v
+YACCFLAGS=-v --strict
 CAMLLEX=$(CAMLRUN) boot/ocamllex
 CAMLDEP=$(CAMLRUN) tools/ocamldep
 DEPFLAGS=$(INCLUDES)
@@ -55,7 +55,7 @@ PARSING=parsing/location.cmo parsing/longident.cmo \
   parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
   parsing/pprintast.cmo \
   parsing/ast_mapper.cmo parsing/ast_iterator.cmo parsing/attr_helper.cmo \
-  parsing/builtin_attributes.cmo parsing/ast_invariants.cmo
+  parsing/builtin_attributes.cmo parsing/ast_invariants.cmo parsing/depend.cmo
 
 TYPING=typing/ident.cmo typing/path.cmo \
   typing/primitive.cmo typing/types.cmo \
@@ -69,8 +69,8 @@ TYPING=typing/ident.cmo typing/path.cmo \
   typing/tast_mapper.cmo \
   typing/cmt_format.cmo typing/untypeast.cmo \
   typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
-  typing/stypes.cmo typing/typecore.cmo \
-  typing/typedecl.cmo typing/typeclass.cmo \
+  typing/stypes.cmo typing/typedecl.cmo typing/typecore.cmo \
+  typing/typeclass.cmo \
   typing/typemod.cmo
 
 COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
@@ -79,7 +79,6 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
   bytecomp/translcore.cmo \
   bytecomp/translclass.cmo bytecomp/translmod.cmo \
   bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
-  bytecomp/debuginfo.cmo \
   driver/pparse.cmo driver/main_args.cmo \
   driver/compenv.cmo driver/compmisc.cmo
 
@@ -89,6 +88,7 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
   bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \
   bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \
   bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \
+  driver/compdynlink.cmo driver/compplugin.cmo \
   driver/errors.cmo driver/compile.cmo
 
 INTEL_ASM=\
@@ -121,7 +121,8 @@ ASMCOMP=\
   asmcomp/import_approx.cmo \
   asmcomp/un_anf.cmo \
   asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \
-  asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
+  asmcomp/printmach.cmo asmcomp/selectgen.cmo \
+  asmcomp/spacetime_profiling.cmo asmcomp/selection.cmo \
   asmcomp/comballoc.cmo \
   asmcomp/CSEgen.cmo asmcomp/CSE.cmo \
   asmcomp/liveness.cmo \
@@ -138,6 +139,7 @@ ASMCOMP=\
   driver/opterrors.cmo driver/optcompile.cmo
 
 MIDDLE_END=\
+  middle_end/debuginfo.cmo \
   middle_end/base_types/tag.cmo \
   middle_end/base_types/linkage_name.cmo \
   middle_end/base_types/compilation_unit.cmo \
@@ -213,14 +215,17 @@ PERVASIVES=$(STDLIB_MODULES) outcometree topdirs toploop
 
 
 # The middle end (whose .cma library is currently only used for linking
-# the "objinfo" program, since we cannot depend on the whole native code
+# the "ocamlobjinfo" program, since we cannot depend on the whole native code
 # compiler for "make world" and the list of dependencies for
 # asmcomp/export_info.cmo is long).
 
 compilerlibs/ocamlmiddleend.cma: $(MIDDLE_END)
        $(CAMLC) -a -o $@ $(MIDDLE_END)
+compilerlibs/ocamlmiddleend.cmxa: $(MIDDLE_END:%.cmo=%.cmx)
+       $(CAMLOPT) -a -o $@ $^
 partialclean::
-       rm -f compilerlibs/ocamlmiddleend.cma
+       rm -f compilerlibs/ocamlmiddleend.cma compilerlibs/ocamlmiddleend.cmxa \
+             compilerlibs/ocamlmiddleend.$(A)
 
 
 # Tools
@@ -228,17 +233,86 @@ partialclean::
 ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \
             asmcomp/printclambda.cmo compilerlibs/ocamlmiddleend.cma \
             asmcomp/export_info.cmo
-       cd tools ; $(MAKEREC) all
+       +cd tools ; $(MAKEREC) all
 
 ocamltoolsopt: ocamlopt
-       cd tools; $(MAKEREC) opt
+       +cd tools; $(MAKEREC) opt
 
-ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi \
-                   asmcomp/printclambda.cmx
-       cd tools; $(MAKEREC) opt.opt
+ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex.opt asmcomp/cmx_format.cmi \
+                   asmcomp/printclambda.cmx compilerlibs/ocamlmiddleend.cmxa \
+                   asmcomp/export_info.cmx
+       +cd tools; $(MAKEREC) opt.opt
 
 partialclean::
-       cd tools; $(MAKEREC) clean
+       +cd tools; $(MAKEREC) clean
 
 alldepend::
-       cd tools; $(MAKEREC) depend
+       +cd tools; $(MAKEREC) depend
+
+#config/Makefile: configure
+#      ./configure $(CONFIGURE_ARGS)
+
+## Test compilation of backend-specific parts
+
+ARCH_SPECIFIC = \
+  asmcomp/arch.ml asmcomp/proc.ml asmcomp/CSE.ml asmcomp/selection.ml \
+  asmcomp/scheduling.ml asmcomp/reload.ml asmcomp/scheduling.ml \
+  asmcomp/emit.ml
+
+partialclean::
+       rm -f $(ARCH_SPECIFIC)
+
+beforedepend:: $(ARCH_SPECIFIC)
+
+ARCH_OCAMLOPT:=$(ARCH)
+
+.PHONY: check_arch check_all_arches
+
+# This rule provides a quick way to check that machine-dependent
+# files compiles fine for a foreign architecture (passed as ARCH=xxx).
+
+check_arch:
+       @echo "========= CHECKING asmcomp/$(ARCH) =============="
+       @rm -f $(ARCH_SPECIFIC) asmcomp/*.cm*
+       @$(MAKEREC) ARCH_OCAMLOPT=$(ARCH) compilerlibs/ocamloptcomp.cma \
+                   >/dev/null
+       @rm -f $(ARCH_SPECIFIC) asmcomp/*.cm*
+
+ARCHES=amd64 i386 arm arm64 power sparc s390x
+
+check_all_arches:
+       @for i in $(ARCHES); do \
+         $(MAKEREC) --no-print-directory check_arch ARCH=$$i; \
+       done
+
+# Compiler Plugins
+
+DYNLINK_DIR=otherlibs/dynlink
+
+driver/compdynlink.mlbyte: $(DYNLINK_DIR)/dynlink.ml driver/compdynlink.mli
+       grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \
+            $(DYNLINK_DIR)/dynlink.ml >driver/compdynlink.mlbyte
+
+ifeq ($(NATDYNLINK),true)
+driver/compdynlink.mlopt: $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mli
+       cp $(DYNLINK_DIR)/natdynlink.ml driver/compdynlink.mlopt
+else
+driver/compdynlink.mlopt: driver/compdynlink.mlno driver/compdynlink.mli
+       cp driver/compdynlink.mlno driver/compdynlink.mlopt
+endif
+
+driver/compdynlink.mli: $(DYNLINK_DIR)/dynlink.mli
+       cp $(DYNLINK_DIR)/dynlink.mli driver/compdynlink.mli
+
+driver/compdynlink.cmo: driver/compdynlink.mlbyte driver/compdynlink.cmi
+       $(CAMLC) $(COMPFLAGS) -c -impl $<
+
+driver/compdynlink.cmx: driver/compdynlink.mlopt driver/compdynlink.cmi
+       $(CAMLOPT) $(COMPFLAGS) -c -impl $<
+
+beforedepend:: driver/compdynlink.mlbyte driver/compdynlink.mlopt \
+               driver/compdynlink.mli
+partialclean::
+       rm -f driver/compdynlink.mlbyte
+       rm -f driver/compdynlink.mli
+       rm -f driver/compdynlink.mlopt

diff --git a/Makefile.tools b/Makefile.tools
new file mode 100644 (file)
index 0000000..9ec9a98
--- /dev/null
+++ b/Makefile.tools
@@ -0,0 +1,109 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# This makefile provides variables for using the in-tree compiler,
+# interpreter, lexer and other associated tools. It is intended to be
+# included within other makefiles.
+# See testsuite/makefiles/Makefile.common, manual/tools/Makefile and
+# manual/manual/tutorials/Makefile as examples.
+# Note that these makefile should define the $(TOPDIR) variable on their
+# own.
+
+WINTOPDIR=`cygpath -m "$(TOPDIR)"`
+
+# TOPDIR is the root directory of the OCaml sources, in Unix syntax.
+# WINTOPDIR is the same directory, in Windows syntax.
+
+OTOPDIR=$(TOPDIR)
+CTOPDIR=$(TOPDIR)
+CYGPATH=echo
+DIFF=diff -q
+SORT=sort
+SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)"
+
+# The variables above may be overridden by .../config/Makefile
+# OTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
+#   arguments given to the OCaml compiler.
+# CTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
+#   arguments given to the C and Fortran compilers.
+# CYGPATH is the command that translates unix-style file names into
+#   whichever syntax is appropriate for arguments of OCaml programs.
+# DIFF is a "diff -q" command that ignores trailing CRs under Windows.
+# SORT is the Unix "sort" command. Usually a simple command, but may be an
+#   absolute name if the Windows "sort" command is in the PATH.
+# SET_LD_PATH is a command prefix that sets the path for dynamic libraries
+#   (CAML_LD_LIBRARY_PATH for Unix, PATH for Windows) using the LD_PATH shell
+#   variable. Note that for Windows we add Unix-syntax directory names in
+#   PATH, and Cygwin will translate it to Windows syntax.
+
+include $(TOPDIR)/config/Makefile
+
+ifneq ($(USE_RUNTIME),)
+#Check USE_RUNTIME value
+ifeq ($(findstring $(USE_RUNTIME),d i),)
+$(error If set, USE_RUNTIME must be equal to "d" (debug runtime) \
+        or "i" (instrumented runtime))
+endif
+
+RUNTIME_VARIANT=-I $(OTOPDIR)/asmrun -I $(OTOPDIR)/byterun \
+                -runtime-variant $(USE_RUNTIME)
+export OCAMLRUNPARAM?=v=0
+endif
+
+OCAMLRUN=$(TOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE)
+
+OCFLAGS=-nostdlib -I $(OTOPDIR)/stdlib $(COMPFLAGS)
+OCOPTFLAGS=
+
+ifeq ($(SUPPORTS_SHARED_LIBRARIES),false)
+  CUSTOM = -custom
+else
+  CUSTOM =
+endif
+
+OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) -noinit
+EXPECT_TEST=$(OCAMLRUN) $(OTOPDIR)/testsuite/tools/expect_test$(EXE)
+ifeq "$(FLEXLINK)" ""
+  FLEXLINK_PREFIX=
+else
+  ifeq "$(wildcard $(TOPDIR)/flexdll/Makefile)" ""
+    FLEXLINK_PREFIX=
+  else
+    EMPTY=
+    FLEXLINK_PREFIX=OCAML_FLEXLINK="$(WINTOPDIR)/boot/ocamlrun \
+                                   $(WINTOPDIR)/flexdll/flexlink.exe" $(EMPTY)
+  endif
+endif
+OCAMLC=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/ocamlc $(CUSTOM) $(OCFLAGS) \
+       $(RUNTIME_VARIANT)
+OCAMLOPT=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/ocamlopt $(OCFLAGS) \
+         $(RUNTIME_VARIANT)
+OCAMLDOC=$(OCAMLRUN) $(OTOPDIR)/ocamldoc/ocamldoc
+OCAMLLEX=$(OCAMLRUN) $(OTOPDIR)/lex/ocamllex
+OCAMLMKLIB=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/tools/ocamlmklib \
+           -ocamlc "$(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) \
+                    $(OTOPDIR)/ocamlc $(OCFLAGS) $(RUNTIME_VARIANT)" \
+           -ocamlopt "$(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) \
+                      $(OTOPDIR)/ocamlopt $(OCFLAGS) $(RUNTIME_VARIANT)"
+OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE)
+DUMPOBJ=$(OCAMLRUN) $(OTOPDIR)/tools/dumpobj
+OBJINFO=$(OCAMLRUN) $(OTOPDIR)/tools/ocamlobjinfo
+BYTECODE_ONLY=[ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]
+NATIVECODE_ONLY=false
+
+#FORTRAN_COMPILER=
+#FORTRAN_LIBRARY=
+
+UNIXLIBVAR=`case "$(OTHERLIBRARIES)" in *win32unix*) echo win32;; esac`

diff --git a/README.adoc b/README.adoc
index 73e477a89b14d288ce779f17972a783f3d21e48b..480b0250f77b1ade7d72f485492060b9e0aeaed6 100644 (file)
--- a/README.adoc
+++ b/README.adoc
@@ -1,25 +1,24 @@
 = README =
 
-== OVERVIEW
+== Overview
 
 OCaml is an implementation of the ML language, based on the Caml Light
-dialect extended with a complete class-based object system and a
-powerful module system in the style of Standard ML.
+dialect extended with a complete class-based object system and a powerful
+module system in the style of Standard ML.
 
 OCaml comprises two compilers. One generates bytecode which is then
-interpreted by a C program. This compiler runs quickly, generates
-compact code with moderate memory requirements, and is portable to
-essentially any 32 or 64 bit Unix platform. Performance of generated
-programs is quite good for a bytecoded implementation.  This compiler
-can be used either as a standalone, batch-oriented compiler that
-produces standalone programs, or as an interactive, toplevel-based
-system.
-
-The other compiler generates high-performance native code for a number
-of processors. Compilation takes longer and generates bigger code, but
-the generated programs deliver excellent performance, while retaining
-the moderate memory requirements of the bytecode compiler. The
-native-code compiler currently runs on the following platforms:
+interpreted by a C program. This compiler runs quickly, generates compact
+code with moderate memory requirements, and is portable to essentially any
+32 or 64 bit Unix platform. Performance of generated programs is quite good
+for a bytecoded implementation.  This compiler can be used either as a
+standalone, batch-oriented compiler that produces standalone programs, or as
+an interactive, toplevel-based system.
+
+The other compiler generates high-performance native code for a number of
+processors. Compilation takes longer and generates bigger code, but the
+generated programs deliver excellent performance, while retaining the
+moderate memory requirements of the bytecode compiler. The native-code
+compiler currently runs on the following platforms:
 
 Tier 1 (actively used and maintained by the core OCaml team):
 
@@ -36,79 +35,92 @@ PowerPC::            NetBSD
 ARM::                NetBSD
 SPARC::              Solaris, Linux, NetBSD
 
-Other operating systems for the processors above have not been tested,
-but the compiler may work under other operating systems with little work.
+Other operating systems for the processors above have not been tested, but
+the compiler may work under other operating systems with little work.
 
-Before the introduction of objects, OCaml was known as Caml Special
-Light. OCaml is almost upwards compatible with Caml Special Light,
-except for a few additional reserved keywords that have forced some
-renaming of standard library functions.
+Before the introduction of objects, OCaml was known as Caml Special Light.
+OCaml is almost upwards compatible with Caml Special Light, except for a few
+additional reserved keywords that have forced some renaming of standard
+library functions.
 
-== CONTENTS
+== Contents
 
   Changes::               what's new with each release
+  configure::             configure script
+  CONTRIBUTING.md::       how to contribute to OCaml
   INSTALL.adoc::          instructions for installation
   LICENSE::               license and copyright notice
   Makefile::              main Makefile
+  Makefile.nt::           MS Windows Makefile
+  Makefile.shared::       common Makefile
+  Makefile.tools::        used by manual/ and testsuite/ Makefiles
   README.adoc::           this file
-  README.win32.adoc::     infos on the MS Windows ports of OCaml
+  README.win32.adoc::     info on the MS Windows ports of OCaml
+  VERSION::               version string
   asmcomp/::              native-code compiler and linker
   asmrun/::               native-code runtime library
   boot/::                 bootstrap compiler
   bytecomp/::             bytecode compiler and linker
   byterun/::              bytecode interpreter and runtime system
+  compilerlibs/::         the OCaml compiler as a library
   config/::               autoconfiguration stuff
   debugger/::             source-level replay debugger
   driver/::               driver code for the compilers
   emacs/::                editing mode and debugger interface for GNU Emacs
+  experimental/::         experiments not built by default
+  flexdll/::              empty (see README.win32.adoc)
   lex/::                  lexer generator
+  man/::                  man pages
+  manual/::               system to generate the manual
+  middle_end/::           the flambda optimisation phase
   ocamldoc/::             documentation generator
   otherlibs/::            several external libraries
   parsing/::              syntax analysis
   stdlib/::               standard library
+  testsuite/::            tests
   tools/::                various utilities
   toplevel/::             interactive system
   typing/::               typechecking
   utils/::                utility libraries
   yacc/::                 parser generator
 
-== COPYRIGHT
+== Copyright
 
-All files marked "Copyright INRIA" in this distribution are copyright
-1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-2007, 2008, 2009, 2010, 2011, 2012 Institut National de Recherche en
-Informatique et en Automatique (INRIA) and distributed under the
-conditions stated in file LICENSE.
+All files marked "Copyright INRIA" in this distribution are copyright 1996,
+1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Institut National de
+Recherche en Informatique et en Automatique (INRIA) and distributed under
+the conditions stated in file LICENSE.
 
-== INSTALLATION
+== Installation
 
-See the file INSTALL for installation instructions on machines running Unix,
+See the file link:INSTALL.adoc[] for installation instructions on machines running Unix,
 Linux, OS X and Cygwin.  For native Microsoft Windows, see
 link:README.win32.adoc[].
 
-== DOCUMENTATION
+== Documentation
 
-The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and
-Emacs Info files.  It is available at
+The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and Emacs
+Info files.  It is available at
 
 http://caml.inria.fr/
 
 The community also maintains the Web site http://ocaml.org, with tutorials
-and other useful informations for OCaml users.
+and other useful information for OCaml users.
 
-== AVAILABILITY
+== Availability
 
 The complete OCaml distribution can be accessed at
 
 http://caml.inria.fr/
 
-== KEEPING IN TOUCH WITH THE CAML COMMUNITY
+== Keeping in Touch with the Caml Community
 
-There exists a mailing list of users of the OCaml implementations
-developed at INRIA. The purpose of this list is to share
-experience, exchange ideas (and even code), and report on applications
-of the OCaml language. Messages can be written in English or in
-French. The list has more than 1000 subscribers.
+There exists a mailing list of users of the OCaml implementations developed
+at INRIA. The purpose of this list is to share experience, exchange ideas
+(and even code), and report on applications of the OCaml language. Messages
+can be written in English or in French. The list has more than 1000
+subscribers.
 
 Messages to the list should be sent to:
 
@@ -120,20 +132,26 @@ https://sympa.inria.fr/sympa/subscribe/caml-list
 
 Archives of the list are available on the Web site above.
 
-The Usenet news `groups comp.lang.ml` and `comp.lang.functional`
-also contains discussions about the ML family of programming languages,
-including OCaml.
+The Usenet news `groups comp.lang.ml` and `comp.lang.functional` also
+contains discussions about the ML family of programming languages, including
+OCaml.
 
 The IRC channel `#ocaml` on https://freenode.net/[Freenode] also has several
 hundred users and welcomes questions.
 
-== BUG REPORTS AND USER FEEDBACK
+The OCaml Community website is
 
-Please report bugs using the Web interface to the bug-tracking system
-at http://caml.inria.fr/bin/caml-bugs
+http://ocaml.org/
 
-To be effective, bug reports should include a complete program
-(preferably small) that exhibits the unexpected behavior, and the
-configuration you are using (machine type, etc).
+== Bug Reports and User Feedback
+
+Please report bugs using the Web interface to the bug-tracking system at
+http://caml.inria.fr/bin/caml-bugs
+
+To be effective, bug reports should include a complete program (preferably
+small) that exhibits the unexpected behavior, and the configuration you are
+using (machine type, etc).
 
 You can also contact the implementors directly at mailto:caml@inria.fr[].
+
+For information on contributing to OCaml, see the file CONTRIBUTING.md.

diff --git a/README.win32.adoc b/README.win32.adoc
index f8b65eaf4ac89ad68936e907667497aec5882954..9d5238cc35e09aedb5fe388d00807ee30563bbc9 100644 (file)
--- a/README.win32.adoc
+++ b/README.win32.adoc
@@ -62,11 +62,13 @@ that a particular build is using the correct installation of `flexlink`.
 
 [[bmflex]]
 In addition to Cygwin, FlexDLL must also be installed, which is available from
-http://alain.frisch.fr/flexdll.html. A binary distribution is available;
+https://github.com/alainfrisch/flexdll. A binary distribution is available;
 instructions on how to build FlexDLL from sources, including how to bootstrap
 FlexDLL and OCaml are given <<seflexdll,later in this document>>.  Unless you
 bootstrap FlexDLL, you will need to ensure that the directory to which you
-install FlexDLL is included in your `PATH` environment variable.
+install FlexDLL is included in your `PATH` environment variable. Note: if you
+use Visual Studio 2015, the binary distribution of FlexDLL will not work and
+you must build it from sources.
 
 The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) of all three
 ports runs without any additional tools.
@@ -103,6 +105,9 @@ Visual C/C++ Compiler.
 
 The command-line tools must be compiled from the Unix source distribution
 (`ocaml-X.YY.Z.tar.gz`), which also contains the files modified for Windows.
+(Note: you should use cygwin's `tar` command to unpack this archive. If you
+use WinZip, you will need to deselect "TAR file smart CR/LF conversion" in
+the WinZip Options Window.)
 
 Microsoft Visual C/C++ is designed to be used from special developer mode
 Command Prompts which set the environment variables for the required compiler.
@@ -244,6 +249,9 @@ package for 64-bit.
 
 The command-line tools must be compiled from the Unix source distribution
 (`ocaml-X.YY.Z.tar.gz`), which also contains the files modified for Windows.
+(Note: you should use cygwin's `tar` command to unpack this archive. If you
+use WinZip, you will need to deselect "TAR file smart CR/LF conversion" in
+the WinZip Options Window.)
 
 Now run:
 
@@ -293,11 +301,11 @@ may need to be careful to ensure that `ocamlopt` picks up the correct `flexlink`
 in your `PATH`.
 
 You must place the FlexDLL sources for Version 0.35 or later in the directory
-`flexdll/` at the top-level directory of the directory of the OCaml
-distribution.  This can be done in one of three ways:
+`flexdll/` at the top-level directory of the OCaml distribution.  This can be
+done in one of three ways:
 
  * Extracting the sources from a tarball from
-   http://alain.frisch.fr/flexdll.html#download
+   https://github.com/alainfrisch/flexdll/releases
  * Cloning the git repository by running:
 +
   git clone https://github.com/alainfrisch/flexdll.git

diff --git a/VERSION b/VERSION
index a376e21d529f2351f3a1de646abeb6ca811d9c2a..ed834ab23b8859c2674029488cf90adc9ba202bb 100644 (file)
--- a/VERSION
+++ b/VERSION
@@ -1,4 +1,4 @@
-4.03.0
+4.04.0
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

diff --git a/appveyor.yml b/appveyor.yml
index ac0db2fb3a43651b3796838285ca597569bb3db4..7d4d8965562d282e04f76f2af46946d42df82314 100644 (file)
--- a/appveyor.yml
+++ b/appveyor.yml
@@ -1,3 +1,17 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                         Christophe Troestler                           *
+#*                                                                        *
+#*   Copyright 2015 Christophe Troestler                                  *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
 # Compile the 64 bits version
 platform:
   - x64

diff --git a/appveyor_build.sh b/appveyor_build.sh
index 7b95b046d2e7280173e744b86697b41f7802059c..b188fc2e2e41127a7c0ff050f6ea3104095fb7a1 100644 (file)
--- a/appveyor_build.sh
+++ b/appveyor_build.sh
@@ -1,4 +1,17 @@
 #!/bin/bash
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                         Christophe Troestler                           *
+#*                                                                        *
+#*   Copyright 2015 Christophe Troestler                                  *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
 
 function run {
     NAME=$1

diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml
index 73bd903dbe984b2c2ebc40e4364b267527b3ba91..07b32f27948f45ba96b82607a374ecd4e606d56c 100644 (file)
--- a/asmcomp/CSEgen.ml
+++ b/asmcomp/CSEgen.ml
@@ -197,7 +197,7 @@ let remove_load_numbering n =
 
 let kill_addr_regs n =
   { n with num_reg =
-              Reg.Map.filter (fun r n -> r.Reg.typ <> Cmm.Addr) n.num_reg }
+              Reg.Map.filter (fun r _n -> r.Reg.typ <> Cmm.Addr) n.num_reg }
 
 (* Prepend a set of moves before [i] to assign [srcs] to [dsts].  *)
 
@@ -207,7 +207,7 @@ let insert_move srcs dsts i =
   match Array.length srcs with
   | 0 -> i
   | 1 -> instr_cons (Iop Imove) srcs dsts i
-  | l -> (* Parallel move: first copy srcs into tmps one by one,
+  | _ -> (* Parallel move: first copy srcs into tmps one by one,
             then copy tmps into dsts one by one *)
          let tmps = Reg.createv_like srcs in
          let i1 = array_fold2 insert_single_move i tmps dsts in
@@ -221,17 +221,16 @@ class cse_generic = object (self)
 method class_of_operation op =
   match op with
   | Imove | Ispill | Ireload -> assert false   (* treated specially *)
-  | Iconst_int _ | Iconst_float _ | Iconst_symbol _
-  | Iconst_blockheader _ -> Op_pure
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Iconst_int _ | Iconst_float _ | Iconst_symbol _ -> Op_pure
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ -> assert false                 (* treated specially *)
   | Istackoffset _ -> Op_other
   | Iload(_,_) -> Op_load
   | Istore(_,_,asg) -> Op_store asg
   | Ialloc _ -> assert false                   (* treated specially *)
-  | Iintop(Icheckbound) -> Op_checkbound
+  | Iintop(Icheckbound _) -> Op_checkbound
   | Iintop _ -> Op_pure
-  | Iintop_imm(Icheckbound, _) -> Op_checkbound
+  | Iintop_imm(Icheckbound _, _) -> Op_checkbound
   | Iintop_imm(_, _) -> Op_pure
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat -> Op_pure
@@ -241,7 +240,7 @@ method class_of_operation op =
 
 method is_cheap_operation op =
   match op with
-  | Iconst_int _ | Iconst_blockheader _ -> true
+  | Iconst_int _ -> true
   | _ -> false
 
 (* Forget all equations involving memory loads.  Performed after a
@@ -255,7 +254,7 @@ method private kill_loads n =
 
 method private cse n i =
   match i.desc with
-  | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _)
+  | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _)
   | Iexit _ | Iraise _ ->
       i
   | Iop (Imove | Ispill | Ireload) ->
@@ -263,7 +262,7 @@ method private cse n i =
          as to the argument reg. *)
       let n1 = set_move n i.arg.(0) i.res.(0) in
       {i with next = self#cse n1 i.next}
-  | Iop (Icall_ind | Icall_imm _ | Iextcall _) ->
+  | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) ->
       (* For function calls, we should at least forget:
          - equations involving memory loads, since the callee can
            perform arbitrary memory stores;

diff --git a/asmcomp/amd64/CSE.ml b/asmcomp/amd64/CSE.ml
index d85e1629b4b2b899a9191fd694aa99d5d976aa16..10066e4b55ccbb9fe750ae61ef605570e7440a85 100644 (file)
--- a/asmcomp/amd64/CSE.ml
+++ b/asmcomp/amd64/CSE.ml
@@ -19,7 +19,7 @@ open Arch
 open Mach
 open CSEgen
 
-class cse = object (self)
+class cse = object
 
 inherit cse_generic as super
 

diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml
index a38e9ad550c8aee2fa1741e15a0785363fed1731..451b431d1d90d7ec5b651ae73ebc8e63c2689cae 100644 (file)
--- a/asmcomp/amd64/arch.ml
+++ b/asmcomp/amd64/arch.ml
@@ -46,6 +46,8 @@ type specific_operation =
 and float_operation =
     Ifloatadd | Ifloatsub | Ifloatmul | Ifloatdiv
 
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
 (* Sizes, endianness *)
 
 let big_endian = false
@@ -73,11 +75,11 @@ let offset_addressing addr delta =
   | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta)
 
 let num_args_addressing = function
-    Ibased(s, n) -> 0
-  | Iindexed n -> 1
-  | Iindexed2 n -> 2
-  | Iscaled(scale, n) -> 1
-  | Iindexed2scaled(scale, n) -> 2
+    Ibased _ -> 0
+  | Iindexed _ -> 1
+  | Iindexed2 _ -> 2
+  | Iscaled _ -> 1
+  | Iindexed2scaled _ -> 2
 
 (* Printing operations and addressing modes *)
 

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 6d0589139bb7d9a8b90f02bb9504ee9b9cd42227..85b4cee313b2c4e6edb6ee44178ceed65638b5b5 100644 (file)
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -168,11 +168,6 @@ let emit_label lbl =
   | S_macosx | S_win64 -> "L" ^ string_of_int lbl
   | _ -> ".L" ^ string_of_int lbl
 
-let emit_data_label lbl =
-  match system with
-  | S_win64 -> "Ld" ^ string_of_int lbl
-  | _ -> ".Ld" ^ string_of_int lbl
-
 let label s = sym (emit_label s)
 
 let def_label s = D.label (emit_label s)
@@ -243,8 +238,12 @@ let addressing addr typ i n =
 
 (* Record live pointers at call points -- see Emitaux *)
 
-let record_frame_label live dbg =
-  let lbl = new_label() in
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -261,45 +260,73 @@ let record_frame_label live dbg =
     { fd_lbl = lbl;
       fd_frame_size = frame_size();
       fd_live_offset = !live_offset;
+      fd_raise = raise_;
       fd_debuginfo = dbg } :: !frame_descriptors;
   lbl
 
-let record_frame live dbg =
-  let lbl = record_frame_label live dbg in
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in
   def_label lbl
 
+(* Spacetime instrumentation *)
+
+let spacetime_before_uninstrumented_call ~node_ptr ~index =
+  (* At the moment, [node_ptr] is pointing at the node for the current
+     OCaml function.  Get hold of the node itself and move the pointer
+     forwards, saving it into the distinguished register.  This is used
+     for instrumentation of function calls (e.g. caml_call_gc and bounds
+     check failures) not inserted until this stage of the compiler
+     pipeline. *)
+  I.mov node_ptr (reg Proc.loc_spacetime_node_hole);
+  assert (index >= 2);
+  I.add (int (index * 8)) (reg Proc.loc_spacetime_node_hole)
+
 (* Record calls to the GC -- we've moved them out of the way *)
 
 type gc_call =
   { gc_lbl: label;                      (* Entry label *)
     gc_return_lbl: label;               (* Where to branch after GC *)
-    gc_frame: label }                   (* Label of frame descriptor *)
+    gc_frame: label;                    (* Label of frame descriptor *)
+    gc_spacetime : (X86_ast.arg * int) option;
+    (* Spacetime node hole pointer and index *)
+  }
 
 let call_gc_sites = ref ([] : gc_call list)
 
 let emit_call_gc gc =
   def_label gc.gc_lbl;
+  begin match gc.gc_spacetime with
+  | None -> assert (not Config.spacetime)
+  | Some (node_ptr, index) ->
+    assert Config.spacetime;
+    spacetime_before_uninstrumented_call ~node_ptr ~index
+  end;
   emit_call "caml_call_gc";
   def_label gc.gc_frame;
   I.jmp (label gc.gc_return_lbl)
 
 (* Record calls to caml_ml_array_bound_error.
-   In -g mode, we maintain one call to caml_ml_array_bound_error
-   per bound check site.  Without -g, we can share a single call. *)
+   In -g mode, or when using Spacetime profiling, we maintain one call to
+   caml_ml_array_bound_error per bound check site.  Without -g, we can share
+   a single call. *)
 
 type bound_error_call =
   { bd_lbl: label;                      (* Entry label *)
-    bd_frame: label }                   (* Label of frame descriptor *)
+    bd_frame: label;                    (* Label of frame descriptor *)
+    bd_spacetime : (X86_ast.arg * int) option;
+    (* As for [gc_call]. *)
+  }
 
 let bound_error_sites = ref ([] : bound_error_call list)
 let bound_error_call = ref 0
 
-let bound_error_label dbg =
-  if !Clflags.debug then begin
+let bound_error_label ?label dbg ~spacetime =
+  if !Clflags.debug || Config.spacetime then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame_label Reg.Set.empty dbg in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
     bound_error_sites :=
-      { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
+      { bd_lbl = lbl_bound_error; bd_frame = lbl_frame;
+        bd_spacetime = spacetime; } :: !bound_error_sites;
     lbl_bound_error
   end else begin
     if !bound_error_call = 0 then bound_error_call := new_label();
@@ -308,6 +335,11 @@ let bound_error_label dbg =
 
 let emit_call_bound_error bd =
   def_label bd.bd_lbl;
+  begin match bd.bd_spacetime with
+  | None -> ()
+  | Some (node_ptr, index) ->
+    spacetime_before_uninstrumented_call ~node_ptr ~index
+  end;
   emit_call "caml_ml_array_bound_error";
   def_label bd.bd_frame
 
@@ -463,7 +495,7 @@ let emit_instr fallthrough i =
         | Float, _, _ -> I.movsd (reg src) (reg dst)
         | _ -> I.mov (reg src) (reg dst)
         end
-  | Lop(Iconst_int n | Iconst_blockheader n) ->
+  | Lop(Iconst_int n) ->
       if n = 0n then begin
         match i.res.(0).loc with
         | Reg _ -> I.xor (res i 0) (res i 0)
@@ -482,32 +514,40 @@ let emit_instr fallthrough i =
   | Lop(Iconst_symbol s) ->
       add_used_symbol s;
       load_symbol_addr s (res i 0)
-  | Lop(Icall_ind) ->
+  | Lop(Icall_ind { label_after; }) ->
       I.call (arg i 0);
-      record_frame i.live i.dbg
-  | Lop(Icall_imm s) ->
-      add_used_symbol s;
-      emit_call s;
-      record_frame i.live i.dbg
-  | Lop(Itailcall_ind) ->
+      record_frame i.live false i.dbg ~label:label_after
+  | Lop(Icall_imm { func; label_after; }) ->
+      add_used_symbol func;
+      emit_call func;
+      record_frame i.live false i.dbg ~label:label_after
+  | Lop(Itailcall_ind { label_after; }) ->
       output_epilogue begin fun () ->
-        I.jmp (arg i 0)
+        I.jmp (arg i 0);
+        if Config.spacetime then begin
+          record_frame Reg.Set.empty false i.dbg ~label:label_after
+        end
       end
-  | Lop(Itailcall_imm s) ->
-      if s = !function_name then
-        I.jmp (label !tailrec_entry_point)
-      else begin
-        output_epilogue begin fun () ->
-          add_used_symbol s;
-          emit_jump s
+  | Lop(Itailcall_imm { func; label_after; }) ->
+      begin
+        if func = !function_name then
+          I.jmp (label !tailrec_entry_point)
+        else begin
+          output_epilogue begin fun () ->
+            add_used_symbol func;
+            emit_jump func
+          end
         end
+      end;
+      if Config.spacetime then begin
+        record_frame Reg.Set.empty false i.dbg ~label:label_after
       end
-  | Lop(Iextcall(s, alloc)) ->
-      add_used_symbol s;
+  | Lop(Iextcall { func; alloc; label_after; }) ->
+      add_used_symbol func;
       if alloc then begin
-        load_symbol_addr s rax;
+        load_symbol_addr func rax;
         emit_call "caml_c_call";
-        record_frame i.live i.dbg;
+        record_frame i.live false i.dbg ~label:label_after;
         if system <> S_win64 then begin
           (* TODO: investigate why such a diff.
              This comes from:
@@ -518,9 +558,13 @@ let emit_instr fallthrough i =
           *)
           load_symbol_addr "caml_young_ptr" r11;
           I.mov (mem64 QWORD 0 R11) r15
-        end;
-      end else
-        emit_call s
+        end
+      end else begin
+        emit_call func;
+        if Config.spacetime then begin
+          record_frame Reg.Set.empty false i.dbg ~label:label_after
+        end
+      end
   | Lop(Istackoffset n) ->
       if n < 0
       then I.add (int (-n)) rsp
@@ -567,25 +611,53 @@ let emit_instr fallthrough i =
       | Double | Double_u ->
           I.movsd (arg i 0) (addressing addr REAL8 i 1)
       end
-  | Lop(Ialloc n) ->
+  | Lop(Ialloc { words = n; label_after_call_gc; spacetime_index; }) ->
       if !fastcode_flag then begin
         let lbl_redo = new_label() in
         def_label lbl_redo;
         I.sub (int n) r15;
+        let spacetime_node_hole_ptr_is_in_rax =
+          Config.spacetime && (i.arg.(0).loc = Reg 0)
+        in
         if !Clflags.dlcode then begin
+          (* When using Spacetime, %rax might be the node pointer, so we
+             must take care not to clobber it.  (Whilst we can tell the
+             register allocator that %rax is destroyed by Ialloc, we can't
+             force that the argument (the node pointer) is not in %rax.) *)
+          if spacetime_node_hole_ptr_is_in_rax then begin
+            I.push rax
+          end;
           load_symbol_addr "caml_young_limit" rax;
           I.cmp (mem64 QWORD 0 RAX) r15;
+          if spacetime_node_hole_ptr_is_in_rax then begin
+            I.pop rax  (* this does not affect the flags *)
+          end
         end else
           I.cmp (mem64_rip QWORD (emit_symbol "caml_young_limit")) r15;
         let lbl_call_gc = new_label() in
-        let lbl_frame = record_frame_label i.live Debuginfo.none in
+        let dbg =
+          if not Config.spacetime then Debuginfo.none
+          else i.dbg
+        in
+        let lbl_frame =
+          record_frame_label ?label:label_after_call_gc i.live false dbg
+        in
         I.jb (label lbl_call_gc);
         I.lea (mem64 NONE 8 R15) (res i 0);
+        let gc_spacetime =
+          if not Config.spacetime then None
+          else Some (arg i 0, spacetime_index)
+        in
         call_gc_sites :=
           { gc_lbl = lbl_call_gc;
             gc_return_lbl = lbl_redo;
-            gc_frame = lbl_frame } :: !call_gc_sites
+            gc_frame = lbl_frame;
+            gc_spacetime; } :: !call_gc_sites
       end else begin
+        if Config.spacetime then begin
+          spacetime_before_uninstrumented_call ~node_ptr:(arg i 0)
+            ~index:spacetime_index;
+        end;
         begin match n with
         | 16 -> emit_call "caml_alloc1"
         | 24 -> emit_call "caml_alloc2"
@@ -594,7 +666,11 @@ let emit_instr fallthrough i =
             I.mov (int n) rax;
             emit_call "caml_allocN"
         end;
-        record_frame i.live Debuginfo.none;
+        let label =
+          record_frame_label ?label:label_after_call_gc i.live false
+            Debuginfo.none
+        in
+        def_label label;
         I.lea (mem64 NONE 8 R15) (res i 0)
       end
   | Lop(Iintop(Icomp cmp)) ->
@@ -605,12 +681,20 @@ let emit_instr fallthrough i =
       I.cmp (int n) (arg i 0);
       I.set (cond cmp) al;
       I.movzx al (res i 0)
-  | Lop(Iintop Icheckbound) ->
-      let lbl = bound_error_label i.dbg in
+  | Lop(Iintop (Icheckbound { label_after_error; spacetime_index; } )) ->
+      let spacetime =
+        if not Config.spacetime then None
+        else Some (arg i 2, spacetime_index)
+      in
+      let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in
       I.cmp (arg i 1) (arg i 0);
       I.jbe (label lbl)
-  | Lop(Iintop_imm(Icheckbound, n)) ->
-      let lbl = bound_error_label i.dbg in
+  | Lop(Iintop_imm(Icheckbound { label_after_error; spacetime_index; }, n)) ->
+      let spacetime =
+        if not Config.spacetime then None
+        else Some (arg i 1, spacetime_index)
+      in
+      let lbl = bound_error_label ?label:label_after_error i.dbg ~spacetime in
       I.cmp (int n) (arg i 0);
       I.jbe (label lbl)
   | Lop(Iintop(Idiv | Imod)) ->
@@ -766,15 +850,14 @@ let emit_instr fallthrough i =
       cfi_adjust_cfa_offset (-8);
       stack_offset := !stack_offset - 16
   | Lraise k ->
-      begin match !Clflags.debug, k with
-      | true, Lambda.Raise_regular ->
+      (* No Spacetime instrumentation is required for [caml_raise_exn] and
+         [caml_reraise_exn].  The only function called that might affect the
+         trie is [caml_stash_backtrace], and it does not. *)
+      begin match k with
+      | Cmm.Raise_withtrace ->
           emit_call "caml_raise_exn";
-          record_frame Reg.Set.empty i.dbg
-      | true, Lambda.Raise_reraise ->
-          emit_call "caml_reraise_exn";
-          record_frame Reg.Set.empty i.dbg
-      | false, _
-      | true, Lambda.Raise_notrace ->
+          record_frame Reg.Set.empty true i.dbg
+      | Cmm.Raise_notrace ->
           I.mov r14 rsp;
           I.pop r14;
           I.ret ()
@@ -798,10 +881,14 @@ let emit_profile () =
        like mcount expects it, though. *)
     I.push r10;
     if not fp then I.mov rsp rbp;
+    (* No Spacetime instrumentation needed: [mcount] cannot call anything
+       OCaml-related. *)
     emit_call "mcount";
     I.pop r10
   end
 
+let all_functions = ref []
+
 (* Emission of a function declaration *)
 
 let fundecl fundecl =
@@ -812,6 +899,7 @@ let fundecl fundecl =
   call_gc_sites := [];
   bound_error_sites := [];
   bound_error_call := 0;
+  all_functions := fundecl :: !all_functions;
   D.text ();
   D.align 16;
   add_def_symbol fundecl.fun_name;
@@ -866,7 +954,6 @@ let fundecl fundecl =
 let emit_item = function
   | Cglobal_symbol s -> D.global (emit_symbol s)
   | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s)
-  | Cdefine_label lbl -> _label (emit_data_label lbl)
   | Cint8 n -> D.byte (const n)
   | Cint16 n -> D.word (const n)
   | Cint32 n -> D.long (const_nat n)
@@ -874,7 +961,6 @@ let emit_item = function
   | Csingle f -> D.long  (Const (Int64.of_int32 (Int32.bits_of_float f)))
   | Cdouble f -> D.qword (Const (Int64.bits_of_float f))
   | Csymbol_address s -> add_used_symbol s; D.qword (ConstLabel (emit_symbol s))
-  | Clabel_address lbl -> D.qword (ConstLabel (emit_data_label lbl))
   | Cstring s -> D.bytes s
   | Cskip n -> if n > 0 then D.space n
   | Calign n -> D.align n
@@ -890,6 +976,7 @@ let begin_assembly() =
   reset_debug_info();                   (* PR#5603 *)
   reset_imp_table();
   float_constants := [];
+  all_functions := [];
   if system = S_win64 then begin
     D.extrn "caml_young_ptr" QWORD;
     D.extrn "caml_young_limit" QWORD;
@@ -902,7 +989,6 @@ let begin_assembly() =
     D.extrn "caml_alloc3" NEAR;
     D.extrn "caml_ml_array_bound_error" NEAR;
     D.extrn "caml_raise_exn" NEAR;
-    D.extrn "caml_reraise_exn" NEAR;
   end;
 
 
@@ -932,6 +1018,40 @@ let begin_assembly() =
   if system = S_macosx then I.nop (); (* PR#4690 *)
   ()
 
+let emit_spacetime_shapes () =
+  D.data ();
+  D.align 8;
+  emit_global_label "spacetime_shapes";
+  List.iter (fun fundecl ->
+      (* CR-someday mshinwell: some of this should be platform independent *)
+      begin match fundecl.fun_spacetime_shape with
+      | None -> ()
+      | Some shape ->
+        let funsym = emit_symbol fundecl.fun_name in
+        D.comment ("Shape for " ^ funsym ^ ":");
+        D.qword (ConstLabel funsym);
+        List.iter (fun (part_of_shape, label) ->
+            let tag =
+              match part_of_shape with
+              | Direct_call_point _ -> 1
+              | Indirect_call_point -> 2
+              | Allocation_point -> 3
+            in
+            D.qword (Const (Int64.of_int tag));
+            D.qword (ConstLabel (emit_label label));
+            begin match part_of_shape with
+            | Direct_call_point { callee; } ->
+              D.qword (ConstLabel (emit_symbol callee))
+            | Indirect_call_point -> ()
+            | Allocation_point -> ()
+            end)
+          shape;
+          D.qword (Const 0L)
+      end)
+    !all_functions;
+  D.qword (Const 0L);
+  D.comment "End of Spacetime shapes."
+
 let end_assembly() =
   if !float_constants <> [] then begin
     begin match system with
@@ -959,7 +1079,8 @@ let end_assembly() =
 
   let setcnt = ref 0 in
   emit_frames
-    { efa_label = (fun l -> D.qword (ConstLabel (emit_label l)));
+    { efa_code_label = (fun l -> D.qword (ConstLabel (emit_label l)));
+      efa_data_label = (fun l -> D.qword (ConstLabel (emit_label l)));
       efa_16 = (fun n -> D.word (const n));
       efa_32 = (fun n -> D.long (const_32 n));
       efa_word = (fun n -> D.qword (const n));
@@ -983,6 +1104,10 @@ let end_assembly() =
       efa_string = (fun s -> D.bytes (s ^ "\000"))
     };
 
+  if Config.spacetime then begin
+    emit_spacetime_shapes ()
+  end;
+
   if system = S_linux then
     (* Mark stack as non-executable, PR#4564 *)
     D.section [".note.GNU-stack"] (Some "") [ "%progbits" ];

diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml
index 3f18d50d619d22241eb069cc975ff90905ee8a42..92f68b50a2aa56d367e8390ede6452a52bfbc826 100644 (file)
--- a/asmcomp/amd64/proc.ml
+++ b/asmcomp/amd64/proc.ml
@@ -31,13 +31,6 @@ let win64 =
   | "win64" | "mingw64" | "cygwin" -> true
   | _                   -> false
 
-(* Which asm conventions to use *)
-
-let masm =
-  match Config.ccomp_type with
-  | "msvc" -> true
-  | _      -> false
-
 (* Registers available for register allocation *)
 
 (* Register map:
@@ -138,8 +131,8 @@ let phys_reg n =
   if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
 
 let rax = phys_reg 0
-let rcx = phys_reg 5
 let rdx = phys_reg 4
+let r13 = phys_reg 9
 let rbp = phys_reg 12
 let rxmm15 = phys_reg 115
 
@@ -181,14 +174,22 @@ let calling_conventions first_int last_int first_float last_float make_stack
 
 let incoming ofs = Incoming ofs
 let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
+
+let max_int_args_in_regs () =
+  if Config.spacetime then 9 else 10
 
 let loc_arguments arg =
-  calling_conventions 0 9 100 109 outgoing arg
+  calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 outgoing arg
 let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc
+  let (loc, _ofs) =
+    calling_conventions 0 ((max_int_args_in_regs ()) - 1) 100 109 incoming arg
+  in
+  loc
 let loc_results res =
-  let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+
+let loc_spacetime_node_hole = r13
 
 (* C calling conventions under Unix:
      first integer args in rdi, rsi, rdx, rcx, r8, r9
@@ -204,7 +205,7 @@ let loc_results res =
      Return value in rax or xmm0. *)
 
 let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
 
 let unix_loc_external_arguments arg =
   calling_conventions 2 7 100 107 outgoing arg
@@ -253,7 +254,7 @@ let loc_exn_bucket = rax
 
 (* Volatile registers: none *)
 
-let regs_are_volatile rs = false
+let regs_are_volatile _rs = false
 
 (* Registers destroyed by operations *)
 
@@ -271,13 +272,20 @@ let destroyed_at_c_call =
        108;109;110;111;112;113;114;115])
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
   | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _))
         -> [| rax; rdx |]
   | Iop(Istore(Single, _, _)) -> [| rxmm15 |]
+  | Iop(Ialloc _) when Config.spacetime
+        -> [| rax; loc_spacetime_node_hole |]
   | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _))
         -> [| rax |]
+  | Iop (Iintop (Icheckbound _)) when Config.spacetime ->
+      [| loc_spacetime_node_hole |]
+  | Iop (Iintop_imm(Icheckbound _, _)) when Config.spacetime ->
+      [| loc_spacetime_node_hole |]
   | Iswitch(_, _) -> [| rax; rdx |]
   | _ ->
     if fp then
@@ -293,11 +301,11 @@ let destroyed_at_raise = all_phys_regs
 
 
 let safe_register_pressure = function
-    Iextcall(_,_) -> if win64 then if fp then 7 else 8 else 0
+    Iextcall _ -> if win64 then if fp then 7 else 8 else 0
   | _ -> if fp then 10 else 11
 
 let max_register_pressure = function
-    Iextcall(_, _) ->
+    Iextcall _ ->
       if win64 then
         if fp then [| 7; 10 |]  else [| 8; 10 |]
         else
@@ -314,9 +322,9 @@ let max_register_pressure = function
    registers). *)
 
 let op_is_pure = function
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
   | Ispecific(Ilea _) -> true
   | Ispecific _ -> false
   | _ -> true

diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml
index 9ea80d066b733d88da03066778d75d39be939f36..2e29de4c19f6162ff3e5fe4905a68652b01ba9f4 100644 (file)
--- a/asmcomp/amd64/reload.ml
+++ b/asmcomp/amd64/reload.ml
@@ -24,8 +24,7 @@ open Mach
    Operation                    Res     Arg1    Arg2
      Imove                      R       S
                              or S       R
-     Iconst_int         ]       S if 32-bit signed, R otherwise
-     Iconst_blockheader ]
+     Iconst_int                 S if 32-bit signed, R otherwise
      Iconst_float               R
      Iconst_symbol (not PIC)    S
      Iconst_symbol (PIC)        R
@@ -66,7 +65,7 @@ inherit Reloadgen.reload_generic as super
 
 method! reload_operation op arg res =
   match op with
-  | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) ->
+  | Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) ->
       (* One of the two arguments can reside in the stack, but not both *)
       if stackp arg.(0) && stackp arg.(1)
       then ([|arg.(0); self#makereg arg.(1)|], res)
@@ -90,7 +89,7 @@ method! reload_operation op arg res =
   | Ifloatofint | Iintoffloat ->
       (* Result must be in register, but argument can be on stack *)
       (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res))
-  | Iconst_int n | Iconst_blockheader n ->
+  | Iconst_int n ->
       if n <= 0x7FFFFFFFn && n >= -0x80000000n
       then (arg, res)
       else super#reload_operation op arg res
@@ -103,7 +102,7 @@ method! reload_operation op arg res =
 
 method! reload_test tst arg =
   match tst with
-    Iinttest cmp ->
+    Iinttest _ ->
       (* One of the two arguments can reside on stack *)
       if stackp arg.(0) && stackp arg.(1)
       then [| self#makereg arg.(0); arg.(1) |]

diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml
index 3c1a344ec6dbe0ca9f19dd8b360494969b9166b5..fb50bc150a1f04b8de769fcfb61a2b9496be3bbf 100644 (file)
--- a/asmcomp/amd64/selection.ml
+++ b/asmcomp/amd64/selection.ml
@@ -123,25 +123,27 @@ let inline_ops =
 
 class selector = object (self)
 
-inherit Selectgen.selector_generic as super
+inherit Spacetime_profiling.instruction_selection as super
 
-method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000
+method is_immediate n = n <= 0x7FFF_FFFF && n >= (-1-0x7FFF_FFFF)
+  (* -1-.... : hack so that this can be compiled on 32-bit
+     (cf 'make check_all_arches') *)
 
 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
 
 method! is_simple_expr e =
   match e with
-  | Cop(Cextcall(fn, _, _, _), args)
+  | Cop(Cextcall (fn, _, _, _, _), args)
     when List.mem fn inline_ops ->
       (* inlined ops are simple if their arguments are *)
       List.for_all self#is_simple_expr args
   | _ ->
       super#is_simple_expr e
 
-method select_addressing chunk exp =
+method select_addressing _chunk exp =
   let (a, d) = select_addr exp in
   (* PR#4625: displacement must be a signed 32-bit immediate *)
-  if d < -0x8000_0000 || d > 0x7FFF_FFFF
+  if not (self # is_immediate d)
   then (Iindexed 0, exp)
   else match a with
     | Asymbol s ->
@@ -159,7 +161,10 @@ method! select_store is_assign addr exp =
   match exp with
     Cconst_int n when self#is_immediate n ->
       (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
-  | (Cconst_natint n | Cconst_blockheader n) when self#is_immediate_natint n ->
+  | (Cconst_natint n) when self#is_immediate_natint n ->
+      (Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
+  | (Cblockheader(n, _dbg))
+      when self#is_immediate_natint n && not Config.spacetime ->
       (Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
   | Cconst_pointer n when self#is_immediate n ->
       (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
@@ -175,7 +180,7 @@ method! select_operation op args =
   (* Recognize the LEA instruction *)
     Caddi | Caddv | Cadda | Csubi ->
       begin match self#select_addressing Word_int (Cop(op, args)) with
-        (Iindexed d, _) -> super#select_operation op args
+        (Iindexed _, _)
       | (Iindexed2 0, _) -> super#select_operation op args
       | (addr, arg) -> (Ispecific(Ilea addr), [arg])
       end
@@ -188,7 +193,7 @@ method! select_operation op args =
       self#select_floatarith true Imulf Ifloatmul args
   | Cdivf ->
       self#select_floatarith false Idivf Ifloatdiv args
-  | Cextcall("sqrt", _, false, _) ->
+  | Cextcall("sqrt", _, false, _, _) ->
      begin match args with
        [Cop(Cload (Double|Double_u as chunk), [loc])] ->
          let (addr, arg) = self#select_addressing chunk loc in
@@ -208,12 +213,12 @@ method! select_operation op args =
       | _ ->
           super#select_operation op args
       end
-  | Cextcall("caml_bswap16_direct", _, _, _) ->
+  | Cextcall("caml_bswap16_direct", _, _, _, _) ->
       (Ispecific (Ibswap 16), args)
-  | Cextcall("caml_int32_direct_bswap", _, _, _) ->
+  | Cextcall("caml_int32_direct_bswap", _, _, _, _) ->
       (Ispecific (Ibswap 32), args)
-  | Cextcall("caml_int64_direct_bswap", _, _, _)
-  | Cextcall("caml_nativeint_direct_bswap", _, _, _) ->
+  | Cextcall("caml_int64_direct_bswap", _, _, _, _)
+  | Cextcall("caml_nativeint_direct_bswap", _, _, _, _) ->
       (Ispecific (Ibswap 64), args)
   (* AMD64 does not support immediate operands for multiply high signed *)
   | Cmulhi ->

diff --git a/asmcomp/arm/CSE.ml b/asmcomp/arm/CSE.ml
index 3ab5a35d76acb49fdd995cf2b4ccf407532bcdf1..2269cbec34cbaa91c423663023f1efcb578a14d1 100644 (file)
--- a/asmcomp/arm/CSE.ml
+++ b/asmcomp/arm/CSE.ml
@@ -19,7 +19,7 @@ open Arch
 open Mach
 open CSEgen
 
-class cse = object (self)
+class cse = object
 
 inherit cse_generic as super
 
@@ -31,7 +31,7 @@ method! class_of_operation op =
 
 method! is_cheap_operation op =
   match op with
-  | Iconst_int n | Iconst_blockheader n -> n <= 255n && n >= 0n
+  | Iconst_int n -> n <= 255n && n >= 0n
   | _ -> false
 
 end

diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml
index 72f88a05252b77da71c09314a39e27d57e98907f..0bee7e1ee2efac9ebaa879f0ad69a56f9d52df2f 100644 (file)
--- a/asmcomp/arm/arch.ml
+++ b/asmcomp/arm/arch.ml
@@ -137,6 +137,8 @@ and shift_operation =
   | Ishiftlogicalright
   | Ishiftarithmeticright
 
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
 (* Sizes, endianness *)
 
 let big_endian = false
@@ -157,7 +159,7 @@ let identity_addressing = Iindexed 0
 
 let offset_addressing (Iindexed n) delta = Iindexed(n + delta)
 
-let num_args_addressing (Iindexed n) = 1
+let num_args_addressing (Iindexed _) = 1
 
 (* Printing operations and addressing modes *)
 

diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
index a63f9e8b805a0fba05dc3e0ab3c5bb0e0e7c04b0..de61da57d73f0653ecb6402cd49049d24e2a01cb 100644 (file)
--- a/asmcomp/arm/emit.mlp
+++ b/asmcomp/arm/emit.mlp
@@ -1,3 +1,4 @@
+#2 "asmcomp/arm/emit.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -34,9 +35,6 @@ let fastcode_flag = ref true
 let emit_label lbl =
   emit_string ".L"; emit_int lbl
 
-let emit_data_label lbl =
-  emit_string ".Ld"; emit_int lbl
-
 (* Symbols *)
 
 let emit_symbol s =
@@ -101,8 +99,12 @@ let emit_addressing addr r n =
 
 (* Record live pointers at call points *)
 
-let record_frame_label live dbg =
-  let lbl = new_label() in
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -118,11 +120,12 @@ let record_frame_label live dbg =
     { fd_lbl = lbl;
       fd_frame_size = frame_size();
       fd_live_offset = !live_offset;
+      fd_raise = raise_;
       fd_debuginfo = dbg } :: !frame_descriptors;
   lbl
 
-let record_frame live dbg =
-  let lbl = record_frame_label live dbg in `{emit_label lbl}:`
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
 
 (* Record calls to the GC -- we've moved them out of the way *)
 
@@ -147,10 +150,10 @@ type bound_error_call =
 
 let bound_error_sites = ref ([] : bound_error_call list)
 
-let bound_error_label dbg =
+let bound_error_label ?label dbg =
   if !Clflags.debug || !bound_error_sites = [] then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame_label Reg.Set.empty dbg in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
     bound_error_sites :=
       { bd_lbl = lbl_bound_error;
         bd_frame_lbl = lbl_frame } :: !bound_error_sites;
@@ -392,7 +395,7 @@ let emit_instr i =
               `        ldr     {emit_reg dst}, {emit_stack src}\n`
           end; 1
         end
-    | Lop(Iconst_int n | Iconst_blockheader n) ->
+    | Lop(Iconst_int n) ->
         emit_intconst i.res.(0) (Nativeint.to_int32 n)
     | Lop(Iconst_float f) when !fpu = Soft ->
         let high_bits = Int64.to_int32 (Int64.shift_right_logical f 32)
@@ -437,40 +440,40 @@ let emit_instr i =
         end; 1
     | Lop(Iconst_symbol s) ->
         emit_load_symbol_addr i.res.(0) s
-    | Lop(Icall_ind) ->
+    | Lop(Icall_ind { label_after; }) ->
         if !arch >= ARMv5 then begin
           `    blx     {emit_reg i.arg.(0)}\n`;
-          `{record_frame i.live i.dbg}\n`; 1
+          `{record_frame i.live false i.dbg ~label:label_after}\n`; 1
         end else begin
           `    mov     lr, pc\n`;
           `    bx      {emit_reg i.arg.(0)}\n`;
-          `{record_frame i.live i.dbg}\n`; 2
+          `{record_frame i.live false i.dbg ~label:label_after}\n`; 2
         end
-    | Lop(Icall_imm s) ->
-        `      {emit_call s}\n`;
-        `{record_frame i.live i.dbg}\n`; 1
-    | Lop(Itailcall_ind) ->
+    | Lop(Icall_imm { func; label_after; }) ->
+        `      {emit_call func}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`; 1
+    | Lop(Itailcall_ind { label_after = _; }) ->
         output_epilogue begin fun () ->
           if !contains_calls then
             `  ldr     lr, [sp, #{emit_int (-4)}]\n`;
           `    bx      {emit_reg i.arg.(0)}\n`; 2
         end
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name then begin
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then begin
           `    b       {emit_label !tailrec_entry_point}\n`; 1
         end else begin
           output_epilogue begin fun () ->
             if !contains_calls then
               `        ldr     lr, [sp, #{emit_int (-4)}]\n`;
-            `  {emit_jump s}\n`; 2
+            `  {emit_jump func}\n`; 2
           end
         end
-    | Lop(Iextcall(s, false)) ->
-        `      {emit_call s}\n`; 1
-    | Lop(Iextcall(s, true)) ->
-        let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in
+    | Lop(Iextcall { func; alloc = false; }) ->
+        `      {emit_call func}\n`; 1
+    | Lop(Iextcall { func; alloc = true; label_after; }) ->
+        let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) func in
         `      {emit_call "caml_c_call"}\n`;
-        `{record_frame i.live i.dbg}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`;
         1 + ninstr
     | Lop(Istackoffset n) ->
         assert (n mod 8 = 0);
@@ -540,8 +543,10 @@ let emit_instr i =
           | Double_u -> "fstd"
           | _ (* 32-bit quantities *) -> "str" in
         `      {emit_string instr}     {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
-    | Lop(Ialloc n) ->
-        let lbl_frame = record_frame_label i.live i.dbg in
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        let lbl_frame =
+          record_frame_label i.live false i.dbg ?label:label_after_call_gc
+        in
         if !fastcode_flag then begin
           let lbl_redo = new_label() in
           `{emit_label lbl_redo}:`;
@@ -584,12 +589,12 @@ let emit_instr i =
         `      ite     {emit_string compthen}\n`;
         `      mov{emit_string compthen}       {emit_reg i.res.(0)}, #1\n`;
         `      mov{emit_string compelse}       {emit_reg i.res.(0)}, #0\n`; 4
-    | Lop(Iintop Icheckbound) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Iintop (Icheckbound { label_after_error; } )) ->
+        let lbl = bound_error_label ?label:label_after_error i.dbg in
         `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         `      bls     {emit_label lbl}\n`; 2
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+        let lbl = bound_error_label ?label:label_after_error i.dbg in
         `      cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
         `      bls     {emit_label lbl}\n`; 2
     | Lop(Ispecific(Ishiftcheckbound(shiftop, n))) ->
@@ -786,12 +791,11 @@ let emit_instr i =
         cfi_adjust_cfa_offset (-8);
         stack_offset := !stack_offset - 8; 1
     | Lraise k ->
-        begin match !Clflags.debug, k with
-        | true, (Lambda.Raise_regular | Lambda.Raise_reraise) ->
+        begin match k with
+        | Cmm.Raise_withtrace ->
           `    {emit_call "caml_raise_exn"}\n`;
-          `{record_frame Reg.Set.empty i.dbg}\n`; 1
-        | false, _
-        | true, Lambda.Raise_notrace ->
+          `{record_frame Reg.Set.empty true i.dbg}\n`; 1
+        | Cmm.Raise_notrace ->
           `    mov     sp, trap_ptr\n`;
           `    pop     \{trap_ptr, pc}\n`; 2
         end
@@ -875,7 +879,6 @@ let fundecl fundecl =
 let emit_item = function
     Cglobal_symbol s -> `      .globl  {emit_symbol s}\n`;
   | Cdefine_symbol s -> `{emit_symbol s}:\n`
-  | Cdefine_label lbl -> `{emit_data_label lbl}:\n`
   | Cint8 n -> `       .byte   {emit_int n}\n`
   | Cint16 n -> `      .short  {emit_int n}\n`
   | Cint32 n -> `      .long   {emit_int32 (Nativeint.to_int32 n)}\n`
@@ -883,7 +886,6 @@ let emit_item = function
   | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f)
   | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f)
   | Csymbol_address s -> `     .word   {emit_symbol s}\n`
-  | Clabel_address lbl -> `    .word   {emit_data_label lbl}\n`
   | Cstring s -> emit_string_directive "       .ascii  " s
   | Cskip n -> if n > 0 then ` .space  {emit_int n}\n`
   | Calign n -> `      .align  {emit_int(Misc.log2 n)}\n`
@@ -938,9 +940,12 @@ let end_assembly () =
   `    .globl  {emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
   emit_frames
-    { efa_label = (fun lbl ->
+    { efa_code_label = (fun lbl ->
                        `       .type   {emit_label lbl}, %function\n`;
                        `       .word   {emit_label lbl}\n`);
+      efa_data_label = (fun lbl ->
+                       `       .type   {emit_label lbl}, %object\n`;
+                       `       .word   {emit_label lbl}\n`);
       efa_16 = (fun n -> `     .short  {emit_int n}\n`);
       efa_32 = (fun n -> `     .long   {emit_int32 n}\n`);
       efa_word = (fun n -> `   .word   {emit_int n}\n`);

diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml
index a204cfff75fb6d1352008e064eda055f834b1e29..64d9013fc940cf1e1a7f3431c8c134d79ef01a89 100644 (file)
--- a/asmcomp/arm/proc.ml
+++ b/asmcomp/arm/proc.ml
@@ -107,6 +107,8 @@ let phys_reg n =
 let stack_slot slot ty =
   Reg.at_location ty (Stack slot)
 
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
 (* Calling conventions *)
 
 let calling_conventions first_int last_int first_float last_float make_stack
@@ -175,7 +177,7 @@ let calling_conventions first_int last_int first_float last_float make_stack
 
 let incoming ofs = Incoming ofs
 let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
 
 (* OCaml calling convention:
      first integer args in r0...r7
@@ -224,7 +226,7 @@ let loc_exn_bucket = phys_reg 0
 
 (* Volatile registers: none *)
 
-let regs_are_volatile rs = false
+let regs_are_volatile _rs = false
 
 (* Registers destroyed by operations *)
 
@@ -252,10 +254,10 @@ let destroyed_at_c_call =
                          124;125;126;127;128;129;130;131]))
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _)
-  | Iop(Iextcall(_, true)) ->
+    Iop(Icall_ind _ | Icall_imm _)
+  | Iop(Iextcall { alloc = true; _ }) ->
       all_phys_regs
-  | Iop(Iextcall(_, false)) ->
+  | Iop(Iextcall { alloc = false; _}) ->
       destroyed_at_c_call
   | Iop(Ialloc _) ->
       destroyed_at_alloc
@@ -272,14 +274,14 @@ let destroyed_at_raise = all_phys_regs
 (* Maximal register pressure *)
 
 let safe_register_pressure = function
-    Iextcall(_, _) -> if abi = EABI then 0 else 4
+    Iextcall _ -> if abi = EABI then 0 else 4
   | Ialloc _ -> if abi = EABI then 0 else 7
   | Iconst_symbol _ when !Clflags.pic_code -> 7
   | Iintop Imulh when !arch < ARMv6 -> 8
   | _ -> 9
 
 let max_register_pressure = function
-    Iextcall(_, _) -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |]
+    Iextcall _ -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |]
   | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |]
   | Iconst_symbol _ when !Clflags.pic_code -> [| 7; 16; 32 |]
   | Iintoffloat | Ifloatofint
@@ -291,9 +293,9 @@ let max_register_pressure = function
    registers). *)
 
 let op_is_pure = function
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _)
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _)
   | Ispecific(Ishiftcheckbound _) -> false
   | _ -> true
 

diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml
index c89d628a6cee94290526d873fa08625ce8a4a103..4039eaac8b8471341f96959af67e34d538073af6 100644 (file)
--- a/asmcomp/arm/scheduling.ml
+++ b/asmcomp/arm/scheduling.ml
@@ -19,7 +19,7 @@ open Mach
 
 (* Instruction scheduling for the ARM *)
 
-class scheduler = object(self)
+class scheduler = object
 
 inherit Schedgen.scheduler_generic as super
 
@@ -58,8 +58,8 @@ method oper_issue_cycles = function
   | Iintop(Ilsl | Ilsr | Iasr) -> 2
   | Iintop(Icomp _)
   | Iintop_imm(Icomp _, _) -> 3
-  | Iintop(Icheckbound)
-  | Iintop_imm(Icheckbound, _) -> 2
+  | Iintop(Icheckbound _)
+  | Iintop_imm(Icheckbound _, _) -> 2
   | Ispecific(Ishiftcheckbound _) -> 3
   | Iintop(Imul | Imulh)
   | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2

diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml
index d363c556d92fbfd8d60a4a3bd5b3ae26b3c7d24f..2063e6068bac2d010cd75be9c676423bfca68465 100644 (file)
--- a/asmcomp/arm/selection.ml
+++ b/asmcomp/arm/selection.ml
@@ -53,7 +53,6 @@ exception Use_default
 let r1 = phys_reg 1
 let r6 = phys_reg 6
 let r7 = phys_reg 7
-let r12 = phys_reg 8
 
 let pseudoregs_for_operation op arg res =
   match op with
@@ -79,7 +78,7 @@ let pseudoregs_for_operation op arg res =
       (arg', res)
   (* We use __aeabi_idivmod for Cmodi only, and hence we care only
      for the remainder in r1, so fix up the destination register. *)
-  | Iextcall("__aeabi_idivmod", false) ->
+  | Iextcall { func = "__aeabi_idivmod"; alloc = false; } ->
       (arg, [|r1|])
   (* Other instructions are regular *)
   | _ -> raise Use_default
@@ -108,12 +107,14 @@ method is_immediate n =
 
 method! is_simple_expr = function
   (* inlined floating-point ops are simple if their arguments are *)
-  | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv2 ->
+  | Cop(Cextcall("sqrt", _, _, _, _), args) when !fpu >= VFPv2 ->
       List.for_all self#is_simple_expr args
   (* inlined byte-swap ops are simple if their arguments are *)
-  | Cop(Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 ->
+  | Cop(Cextcall("caml_bswap16_direct", _, _, _, _), args)
+    when !arch >= ARMv6T2 ->
       List.for_all self#is_simple_expr args
-  | Cop(Cextcall("caml_int32_direct_bswap", _,_,_), args) when !arch >= ARMv6 ->
+  | Cop(Cextcall("caml_int32_direct_bswap", _,_,_,_), args)
+    when !arch >= ARMv6 ->
       List.for_all self#is_simple_expr args
   | e -> super#is_simple_expr e
 
@@ -165,6 +166,9 @@ method select_shift_arith op arithop arithrevop args =
       | op_args -> op_args
       end
 
+method private iextcall (func, alloc) =
+  Iextcall { func; alloc; label_after = Cmm.new_label (); }
+
 method! select_operation op args =
   match (op, args) with
   (* Recognize special shift arithmetic *)
@@ -197,15 +201,16 @@ method! select_operation op args =
       (Iintop Imulh, args)
   (* Turn integer division/modulus into runtime ABI calls *)
   | (Cdivi, args) ->
-      (Iextcall("__aeabi_idiv", false), args)
+      (self#iextcall("__aeabi_idiv", false), args)
   | (Cmodi, args) ->
       (* See above for fix up of return register *)
-      (Iextcall("__aeabi_idivmod", false), args)
+      (self#iextcall("__aeabi_idivmod", false), args)
   (* Recognize 16-bit bswap instruction (ARMv6T2 because we need movt) *)
-  | (Cextcall("caml_bswap16_direct", _, _, _), args) when !arch >= ARMv6T2 ->
+  | (Cextcall("caml_bswap16_direct", _, _, _, _), args) when !arch >= ARMv6T2 ->
       (Ispecific(Ibswap 16), args)
   (* Recognize 32-bit bswap instructions (ARMv6 and above) *)
-  | (Cextcall("caml_int32_direct_bswap", _, _, _), args) when !arch >= ARMv6 ->
+  | (Cextcall("caml_int32_direct_bswap", _, _, _, _), args)
+    when !arch >= ARMv6 ->
       (Ispecific(Ibswap 32), args)
   (* Turn floating-point operations into runtime ABI calls for softfp *)
   | (op, args) when !fpu = Soft -> self#select_operation_softfp op args
@@ -215,12 +220,12 @@ method! select_operation op args =
 method private select_operation_softfp op args =
   match (op, args) with
   (* Turn floating-point operations into runtime ABI calls *)
-  | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args)
-  | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args)
-  | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args)
-  | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args)
-  | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args)
-  | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args)
+  | (Caddf, args) -> (self#iextcall("__aeabi_dadd", false), args)
+  | (Csubf, args) -> (self#iextcall("__aeabi_dsub", false), args)
+  | (Cmulf, args) -> (self#iextcall("__aeabi_dmul", false), args)
+  | (Cdivf, args) -> (self#iextcall("__aeabi_ddiv", false), args)
+  | (Cfloatofint, args) -> (self#iextcall("__aeabi_i2d", false), args)
+  | (Cintoffloat, args) -> (self#iextcall("__aeabi_d2iz", false), args)
   | (Ccmpf comp, args) ->
       let func = (match comp with
                     Cne    (* there's no __aeabi_dcmpne *)
@@ -233,13 +238,13 @@ method private select_operation_softfp op args =
                     Cne -> Ceq (* eq 0 => false *)
                   | _   -> Cne (* ne 0 => true *)) in
       (Iintop_imm(Icomp(Iunsigned comp), 0),
-       [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)])
+       [Cop(Cextcall(func, typ_int, false, Debuginfo.none, None), args)])
   (* Add coercions around loads and stores of 32-bit floats *)
   | (Cload Single, args) ->
-      (Iextcall("__aeabi_f2d", false), [Cop(Cload Word_int, args)])
+      (self#iextcall("__aeabi_f2d", false), [Cop(Cload Word_int, args)])
   | (Cstore (Single, init), [arg1; arg2]) ->
       let arg2' =
-        Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none),
+        Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none, None),
             [arg2]) in
       self#select_operation (Cstore (Word_int, init)) [arg1; arg2']
   (* Other operations are regular *)
@@ -265,7 +270,7 @@ method private select_operation_vfpv3 op args =
   | (Csubf, [Cop(Cmulf, args); arg]) ->
       (Ispecific Imulsubf, arg :: args)
   (* Recognize floating-point square root *)
-  | (Cextcall("sqrt", _, false, _), args) ->
+  | (Cextcall("sqrt", _, false, _, _), args) ->
       (Ispecific Isqrtf, args)
   (* Other operations are regular *)
   | (op, args) -> super#select_operation op args

diff --git a/asmcomp/arm64/CSE.ml b/asmcomp/arm64/CSE.ml
index 7a8fc17f1dbe293c1d7eedd6db046d3244fe57a5..b97f9227bf0c93b13bd2aa59288603bf23aa4656 100644 (file)
--- a/asmcomp/arm64/CSE.ml
+++ b/asmcomp/arm64/CSE.ml
@@ -19,7 +19,7 @@ open Arch
 open Mach
 open CSEgen
 
-class cse = object (self)
+class cse = object
 
 inherit cse_generic as super
 
@@ -31,7 +31,7 @@ method! class_of_operation op =
 
 method! is_cheap_operation op =
   match op with
-  | Iconst_int n | Iconst_blockheader n -> n <= 65535n && n >= 0n
+  | Iconst_int n -> n <= 65535n && n >= 0n
   | _ -> false
 
 end

diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml
index 5c13957fe0ebbbf8718e12c5daf0f9dfe8307f54..4eb8b9d94094a5e8caf3eb63e747551efc5d80bf 100644 (file)
--- a/asmcomp/arm64/arch.ml
+++ b/asmcomp/arm64/arch.ml
@@ -15,8 +15,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-let command_line_options = []
-
 (* Specific operations for the ARM processor, 64-bit mode *)
 
 open Format
@@ -36,13 +34,18 @@ type addressing_mode =
 
 (* Specific operations *)
 
+type cmm_label = int
+  (* Do not introduce a dependency to Cmm *)
+
 type specific_operation =
-  | Ifar_alloc of int
-  | Ifar_intop_checkbound
-  | Ifar_intop_imm_checkbound of int
+  | Ifar_alloc of { words : int; label_after_call_gc : cmm_label option; }
+  | Ifar_intop_checkbound of { label_after_error : cmm_label option; }
+  | Ifar_intop_imm_checkbound of
+      { bound : int; label_after_error : cmm_label option; }
   | Ishiftarith of arith_operation * int
-  | Ishiftcheckbound of int
-  | Ifar_shiftcheckbound of int
+  | Ishiftcheckbound of { shift : int; label_after_error : cmm_label option; }
+  | Ifar_shiftcheckbound of
+      { shift : int; label_after_error : cmm_label option; }
   | Imuladd       (* multiply and add *)
   | Imulsub       (* multiply and subtract *)
   | Inegmulf      (* floating-point negate and multiply *)
@@ -57,6 +60,12 @@ and arith_operation =
     Ishiftadd
   | Ishiftsub
 
+let spacetime_node_hole_pointer_is_live_before = function
+  | Ifar_alloc _ | Ifar_intop_checkbound _ | Ifar_intop_imm_checkbound _
+  | Ishiftarith _ | Ishiftcheckbound _ | Ifar_shiftcheckbound _ -> false
+  | Imuladd | Imulsub | Inegmulf | Imuladdf | Inegmuladdf | Imulsubf
+  | Inegmulsubf | Isqrtf | Ibswap _ -> false
+
 (* Sizes, endianness *)
 
 let big_endian = false
@@ -81,8 +90,8 @@ let offset_addressing addr delta =
   | Ibased(s, n) -> Ibased(s, n + delta)
 
 let num_args_addressing = function
-  | Iindexed n -> 1
-  | Ibased(s, n) -> 0
+  | Iindexed _ -> 1
+  | Ibased _ -> 0
 
 (* Printing operations and addressing modes *)
 
@@ -98,12 +107,12 @@ let print_addressing printreg addr ppf arg =
 
 let print_specific_operation printreg op ppf arg =
   match op with
-  | Ifar_alloc n ->
-    fprintf ppf "(far) alloc %i" n
-  | Ifar_intop_checkbound ->
+  | Ifar_alloc { words; label_after_call_gc = _; } ->
+    fprintf ppf "(far) alloc %i" words
+  | Ifar_intop_checkbound _ ->
     fprintf ppf "%a (far) check > %a" printreg arg.(0) printreg arg.(1)
-  | Ifar_intop_imm_checkbound n ->
-    fprintf ppf "%a (far) check > %i" printreg arg.(0) n
+  | Ifar_intop_imm_checkbound { bound; _ } ->
+    fprintf ppf "%a (far) check > %i" printreg arg.(0) bound
   | Ishiftarith(op, shift) ->
       let op_name = function
       | Ishiftadd -> "+"
@@ -114,11 +123,12 @@ let print_specific_operation printreg op ppf arg =
        else sprintf ">> %i" (-shift) in
       fprintf ppf "%a %s %a %s"
        printreg arg.(0) (op_name op) printreg arg.(1) shift_mark
-  | Ishiftcheckbound n ->
-      fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1)
-  | Ifar_shiftcheckbound n ->
+  | Ishiftcheckbound { shift; _ } ->
+      fprintf ppf "check %a >> %i > %a" printreg arg.(0) shift
+        printreg arg.(1)
+  | Ifar_shiftcheckbound { shift; _ } ->
       fprintf ppf
-        "(far) check %a >> %i > %a" printreg arg.(0) n printreg arg.(1)
+        "(far) check %a >> %i > %a" printreg arg.(0) shift printreg arg.(1)
   | Imuladd ->
       fprintf ppf "(%a * %a) + %a"
         printreg arg.(0)

diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp
index 9cca60b26e3bda2e8dc3590ec10da38406f05fff..b67723a8ef8e9bb24757b217147ea33c149741d3 100644 (file)
--- a/asmcomp/arm64/emit.mlp
+++ b/asmcomp/arm64/emit.mlp
@@ -1,3 +1,4 @@
+#2 "asmcomp/arm64/emit.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -36,7 +37,6 @@ let reg_trap_ptr = phys_reg 23
 let reg_alloc_ptr = phys_reg 24
 let reg_alloc_limit = phys_reg 25
 let reg_tmp1 = phys_reg 26
-let reg_tmp2 = phys_reg 27
 let reg_x15 = phys_reg 15
 
 (* Output a label *)
@@ -44,9 +44,6 @@ let reg_x15 = phys_reg 15
 let emit_label lbl =
   emit_string ".L"; emit_int lbl
 
-let emit_data_label lbl =
-  emit_string ".Ld"; emit_int lbl
-
 (* Symbols *)
 
 let emit_symbol s =
@@ -121,8 +118,12 @@ let emit_addressing addr r =
 
 (* Record live pointers at call points *)
 
-let record_frame_label live dbg =
-  let lbl = new_label() in
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -138,11 +139,12 @@ let record_frame_label live dbg =
     { fd_lbl = lbl;
       fd_frame_size = frame_size();
       fd_live_offset = !live_offset;
+      fd_raise = raise_;
       fd_debuginfo = dbg } :: !frame_descriptors;
   lbl
 
-let record_frame live dbg =
-  let lbl = record_frame_label live dbg in `{emit_label lbl}:`
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in `{emit_label lbl}:`
 
 (* Record calls to the GC -- we've moved them out of the way *)
 
@@ -167,10 +169,10 @@ type bound_error_call =
 
 let bound_error_sites = ref ([] : bound_error_call list)
 
-let bound_error_label dbg =
+let bound_error_label ?label dbg =
   if !Clflags.debug || !bound_error_sites = [] then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame_label Reg.Set.empty dbg in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
     bound_error_sites :=
       { bd_lbl = lbl_bound_error;
         bd_frame_lbl = lbl_frame } :: !bound_error_sites;
@@ -343,8 +345,8 @@ let num_call_gc_and_check_bound_points instr =
     | Lend -> totals
     | Lop (Ialloc _) when !fastcode_flag ->
       loop instr.next (call_gc + 1, check_bound)
-    | Lop (Iintop Icheckbound)
-    | Lop (Iintop_imm (Icheckbound, _))
+    | Lop (Iintop Icheckbound _)
+    | Lop (Iintop_imm (Icheckbound _, _))
     | Lop (Ispecific (Ishiftcheckbound _)) ->
       let check_bound =
         (* When not in debug mode, there is at most one check-bound point. *)
@@ -355,14 +357,14 @@ let num_call_gc_and_check_bound_points instr =
     (* The following four should never be seen, since this function is run
        before branch relaxation. *)
     | Lop (Ispecific (Ifar_alloc _))
-    | Lop (Ispecific Ifar_intop_checkbound)
+    | Lop (Ispecific Ifar_intop_checkbound _)
     | Lop (Ispecific (Ifar_intop_imm_checkbound _))
     | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false
     | _ -> loop instr.next totals
   in
   loop instr (0, 0)
 
-let max_out_of_line_code_offset instr ~num_call_gc ~num_check_bound =
+let max_out_of_line_code_offset ~num_call_gc ~num_check_bound =
   if num_call_gc < 1 && num_check_bound < 1 then 0
   else begin
     let size_of_call_gc = 2 in
@@ -401,8 +403,8 @@ module BR = Branch_relaxation.Make (struct
 
     let classify_instr = function
       | Lop (Ialloc _)
-      | Lop (Iintop Icheckbound)
-      | Lop (Iintop_imm (Icheckbound, _))
+      | Lop (Iintop Icheckbound _)
+      | Lop (Iintop_imm (Icheckbound _, _))
       | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc
       (* The various "far" variants in [specific_operation] don't need to
          return [Some] here, since their code sequences never contain any
@@ -426,33 +428,34 @@ module BR = Branch_relaxation.Make (struct
   let instr_size = function
     | Lend -> 0
     | Lop (Imove | Ispill | Ireload) -> 1
-    | Lop (Iconst_int n | Iconst_blockheader n) ->
+    | Lop (Iconst_int n) ->
       num_instructions_for_intconst n
     | Lop (Iconst_float _) -> 2
     | Lop (Iconst_symbol _) -> 2
-    | Lop (Icall_ind) -> 1
+    | Lop (Icall_ind _) -> 1
     | Lop (Icall_imm _) -> 1
-    | Lop (Itailcall_ind) -> epilogue_size ()
-    | Lop (Itailcall_imm s) ->
-      if s = !function_name then 1 else epilogue_size ()
-    | Lop (Iextcall (_, false)) -> 1
-    | Lop (Iextcall (_, true)) -> 3
+    | Lop (Itailcall_ind _) -> epilogue_size ()
+    | Lop (Itailcall_imm { func; _ }) ->
+      if func = !function_name then 1 else epilogue_size ()
+    | Lop (Iextcall { alloc = false; }) -> 1
+    | Lop (Iextcall { alloc = true; }) -> 3
     | Lop (Istackoffset _) -> 2
     | Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) ->
       let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in
       based + begin match size with Single -> 2 | _ -> 1 end
     | Lop (Ialloc _) when !fastcode_flag -> 4
     | Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 5
-    | Lop (Ialloc num_words) | Lop (Ispecific (Ifar_alloc num_words)) ->
+    | Lop (Ialloc { words = num_words; _ })
+    | Lop (Ispecific (Ifar_alloc { words = num_words; _ })) ->
       begin match num_words with
       | 16 | 24 | 32 -> 1
       | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_words)
       end
     | Lop (Iintop (Icomp _)) -> 2
     | Lop (Iintop_imm (Icomp _, _)) -> 2
-    | Lop (Iintop Icheckbound) -> 2
-    | Lop (Ispecific Ifar_intop_checkbound) -> 3
-    | Lop (Iintop_imm (Icheckbound, _)) -> 2
+    | Lop (Iintop (Icheckbound _)) -> 2
+    | Lop (Ispecific (Ifar_intop_checkbound _)) -> 3
+    | Lop (Iintop_imm (Icheckbound _, _)) -> 2
     | Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3
     | Lop (Ispecific (Ishiftcheckbound _)) -> 2
     | Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3
@@ -490,30 +493,32 @@ module BR = Branch_relaxation.Make (struct
     | Lpushtrap -> 3
     | Lpoptrap -> 1
     | Lraise k ->
-      begin match !Clflags.debug, k with
-      | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> 1
-      | false, _
-      | true, Lambda.Raise_notrace -> 4
+      begin match k with
+      | Cmm.Raise_withtrace -> 1
+      | Cmm.Raise_notrace -> 4
       end
 
-  let relax_allocation ~num_words =
-    Lop (Ispecific (Ifar_alloc num_words))
+  let relax_allocation ~num_words ~label_after_call_gc =
+    Lop (Ispecific (Ifar_alloc { words = num_words; label_after_call_gc; }))
 
-  let relax_intop_checkbound () =
-    Lop (Ispecific Ifar_intop_checkbound)
+  let relax_intop_checkbound ~label_after_error =
+    Lop (Ispecific (Ifar_intop_checkbound { label_after_error; }))
 
-  let relax_intop_imm_checkbound ~bound =
-    Lop (Ispecific (Ifar_intop_imm_checkbound bound))
+  let relax_intop_imm_checkbound ~bound ~label_after_error =
+    Lop (Ispecific (Ifar_intop_imm_checkbound { bound; label_after_error; }))
 
   let relax_specific_op = function
-    | Ishiftcheckbound shift -> Lop (Ispecific (Ifar_shiftcheckbound shift))
+    | Ishiftcheckbound { shift; label_after_error; } ->
+      Lop (Ispecific (Ifar_shiftcheckbound { shift; label_after_error; }))
     | _ -> assert false
 end)
 
 (* Output the assembly code for allocation. *)
 
-let assembly_code_for_allocation i ~n ~far =
-  let lbl_frame = record_frame_label i.live i.dbg in
+let assembly_code_for_allocation ?label_after_call_gc i ~n ~far =
+  let lbl_frame =
+    record_frame_label ?label:label_after_call_gc i.live false i.dbg
+  in
   if !fastcode_flag then begin
     let lbl_redo = new_label() in
     let lbl_call_gc = new_label() in
@@ -565,7 +570,7 @@ let emit_instr i =
           | _ ->
               assert false
         end
-    | Lop(Iconst_int n | Iconst_blockheader n) ->
+    | Lop(Iconst_int n) ->
         emit_intconst i.res.(0) n
     | Lop(Iconst_float f) ->
         if f = 0L then
@@ -579,25 +584,25 @@ let emit_instr i =
         end
     | Lop(Iconst_symbol s) ->
         emit_load_symbol_addr i.res.(0) s
-    | Lop(Icall_ind) ->
+    | Lop(Icall_ind { label_after; }) ->
         `      blr     {emit_reg i.arg.(0)}\n`;
-        `{record_frame i.live i.dbg}\n`
-    | Lop(Icall_imm s) ->
-        `      bl      {emit_symbol s}\n`;
-        `{record_frame i.live i.dbg}\n`
-    | Lop(Itailcall_ind) ->
+        `{record_frame i.live false i.dbg ~label:label_after}\n`
+    | Lop(Icall_imm { func; label_after; }) ->
+        `      bl      {emit_symbol func}\n`;
+        `{record_frame i.live false i.dbg ~label:label_after}\n`
+    | Lop(Itailcall_ind { label_after = _; }) ->
         output_epilogue (fun () -> `   br      {emit_reg i.arg.(0)}\n`)
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name then
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then
           `    b       {emit_label !tailrec_entry_point}\n`
         else
-          output_epilogue (fun () -> ` b       {emit_symbol s}\n`)
-    | Lop(Iextcall(s, false)) ->
-        `      bl      {emit_symbol s}\n`
-    | Lop(Iextcall(s, true)) ->
-        emit_load_symbol_addr reg_x15 s;
+          output_epilogue (fun () -> ` b       {emit_symbol func}\n`)
+    | Lop(Iextcall { func; alloc = false; label_after = _; }) ->
+        `      bl      {emit_symbol func}\n`
+    | Lop(Iextcall { func; alloc = true; label_after; }) ->
+        emit_load_symbol_addr reg_x15 func;
         `      bl      {emit_symbol "caml_c_call"}\n`;
-        `{record_frame i.live i.dbg}\n`
+        `{record_frame i.live false i.dbg ~label:label_after}\n`
     | Lop(Istackoffset n) ->
         assert (n mod 16 = 0);
         emit_stack_adjustment (-n);
@@ -606,7 +611,7 @@ let emit_instr i =
         let dst = i.res.(0) in
         let base =
           match addr with
-          | Iindexed ofs -> i.arg.(0)
+          | Iindexed _ -> i.arg.(0)
           | Ibased(s, ofs) ->
               `        adrp    {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
               reg_tmp1 in
@@ -633,7 +638,7 @@ let emit_instr i =
         let src = i.arg.(0) in
         let base =
           match addr with
-          | Iindexed ofs -> i.arg.(1)
+          | Iindexed _ -> i.arg.(1)
           | Ibased(s, ofs) ->
               `        adrp    {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
               reg_tmp1 in
@@ -650,44 +655,45 @@ let emit_instr i =
         | Word_int | Word_val | Double | Double_u ->
             `  str     {emit_reg src}, {emit_addressing addr base}\n`
         end
-    | Lop(Ialloc n) ->
-        assembly_code_for_allocation i ~n ~far:false
-    | Lop(Ispecific (Ifar_alloc n)) ->
-        assembly_code_for_allocation i ~n ~far:true
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        assembly_code_for_allocation i ~n ~far:false ?label_after_call_gc
+    | Lop(Ispecific (Ifar_alloc { words = n; label_after_call_gc; })) ->
+        assembly_code_for_allocation i ~n ~far:true ?label_after_call_gc
     | Lop(Iintop(Icomp cmp)) ->
         `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         `      cset    {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
     | Lop(Iintop_imm(Icomp cmp, n)) ->
         `      cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
         `      cset    {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n`
-    | Lop(Iintop Icheckbound) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Iintop (Icheckbound { label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
         `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         `      b.ls    {emit_label lbl}\n`
-    | Lop(Ispecific Ifar_intop_checkbound) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Ispecific Ifar_intop_checkbound { label_after_error; }) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
         let lbl2 = new_label () in
         `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         `      b.hi    {emit_label lbl2}\n`;
         `      b       {emit_label lbl}\n`;
         `{emit_label lbl2}:\n`;
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
         `      cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
         `      b.ls    {emit_label lbl}\n`
-    | Lop(Ispecific(Ifar_intop_imm_checkbound bound)) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Ispecific(
+          Ifar_intop_imm_checkbound { bound; label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
         let lbl2 = new_label () in
         `      cmp     {emit_reg i.arg.(0)}, #{emit_int bound}\n`;
         `      b.hi    {emit_label lbl2}\n`;
         `      b       {emit_label lbl}\n`;
         `{emit_label lbl2}:\n`;
-    | Lop(Ispecific(Ishiftcheckbound shift)) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Ispecific(Ishiftcheckbound { shift; label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
         `      cmp     {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
         `      b.cs    {emit_label lbl}\n`
-    | Lop(Ispecific(Ifar_shiftcheckbound shift)) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Ispecific(Ifar_shiftcheckbound { shift; label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
         let lbl2 = new_label () in
         `      cmp     {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
         `      b.lo    {emit_label lbl2}\n`;
@@ -847,12 +853,11 @@ let emit_instr i =
         cfi_adjust_cfa_offset (-16);
         stack_offset := !stack_offset - 16
     | Lraise k ->
-        begin match !Clflags.debug, k with
-        | true, (Lambda.Raise_regular | Lambda.Raise_reraise) ->
+        begin match k with
+        | Cmm.Raise_withtrace ->
           `    bl      {emit_symbol "caml_raise_exn"}\n`;
-          `{record_frame Reg.Set.empty i.dbg}\n`
-        | false, _
-        | true, Lambda.Raise_notrace ->
+          `{record_frame Reg.Set.empty true i.dbg}\n`
+        | Cmm.Raise_notrace ->
           `    mov     sp, {emit_reg reg_trap_ptr}\n`;
           `    ldr     {emit_reg reg_tmp1}, [sp, #8]\n`;
           `    ldr     {emit_reg reg_trap_ptr}, [sp], 16\n`;
@@ -905,7 +910,7 @@ let fundecl fundecl =
     num_call_gc_and_check_bound_points fundecl.fun_body
   in
   let max_out_of_line_code_offset =
-    max_out_of_line_code_offset fundecl.fun_body ~num_call_gc
+    max_out_of_line_code_offset ~num_call_gc
       ~num_check_bound
   in
   BR.relax fundecl.fun_body ~max_out_of_line_code_offset;
@@ -924,7 +929,6 @@ let fundecl fundecl =
 let emit_item = function
   | Cglobal_symbol s -> `      .globl  {emit_symbol s}\n`;
   | Cdefine_symbol s -> `{emit_symbol s}:\n`
-  | Cdefine_label lbl -> `{emit_data_label lbl}:\n`
   | Cint8 n -> `       .byte   {emit_int n}\n`
   | Cint16 n -> `      .short  {emit_int n}\n`
   | Cint32 n -> `      .long   {emit_nativeint n}\n`
@@ -932,7 +936,6 @@ let emit_item = function
   | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f)
   | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f)
   | Csymbol_address s -> `     .quad   {emit_symbol s}\n`
-  | Clabel_address lbl -> `    .quad   {emit_data_label lbl}\n`
   | Cstring s -> emit_string_directive "       .ascii  " s
   | Cskip n -> if n > 0 then ` .space  {emit_int n}\n`
   | Calign n -> `      .align  {emit_int(Misc.log2 n)}\n`
@@ -970,9 +973,12 @@ let end_assembly () =
   `    .globl  {emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
   emit_frames
-    { efa_label = (fun lbl ->
+    { efa_code_label = (fun lbl ->
                        `       .type   {emit_label lbl}, %function\n`;
                        `       .quad   {emit_label lbl}\n`);
+      efa_data_label = (fun lbl ->
+                       `       .type   {emit_label lbl}, %object\n`;
+                       `       .quad   {emit_label lbl}\n`);
       efa_16 = (fun n -> `     .short  {emit_int n}\n`);
       efa_32 = (fun n -> `     .long   {emit_int32 n}\n`);
       efa_word = (fun n -> `   .quad   {emit_int n}\n`);

diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml
index 86cfb51ed4482f4a8d08fa60dee0e1206f77a99c..94062bbf411646cc83b29095f3d56b5d08c1c686 100644 (file)
--- a/asmcomp/arm64/proc.ml
+++ b/asmcomp/arm64/proc.ml
@@ -104,6 +104,8 @@ let reg_d7 = phys_reg 107
 let stack_slot slot ty =
   Reg.at_location ty (Stack slot)
 
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
 (* Calling conventions *)
 
 let calling_conventions
@@ -135,7 +137,7 @@ let calling_conventions
 
 let incoming ofs = Incoming ofs
 let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
 
 (* OCaml calling convention:
      first integer args in r0...r15
@@ -171,7 +173,7 @@ let loc_exn_bucket = phys_reg 0
 
 (* Volatile registers: none *)
 
-let regs_are_volatile rs = false
+let regs_are_volatile _rs = false
 
 (* Registers destroyed by operations *)
 
@@ -184,9 +186,9 @@ let destroyed_at_c_call =
      124;125;126;127;128;129;130;131])
 
 let destroyed_at_oper = function
-  | Iop(Icall_ind | Icall_imm _) | Iop(Iextcall(_, true)) ->
+  | Iop(Icall_ind _ | Icall_imm _) | Iop(Iextcall { alloc = true; }) ->
       all_phys_regs
-  | Iop(Iextcall(_, false)) ->
+  | Iop(Iextcall { alloc = false; }) ->
       destroyed_at_c_call
   | Iop(Ialloc _) ->
       [| reg_x15 |]
@@ -199,12 +201,12 @@ let destroyed_at_raise = all_phys_regs
 (* Maximal register pressure *)
 
 let safe_register_pressure = function
-  | Iextcall(_, _) -> 8
+  | Iextcall _ -> 8
   | Ialloc _ -> 25
   | _ -> 26
 
 let max_register_pressure = function
-  | Iextcall(_, _) -> [| 10; 8 |]
+  | Iextcall _ -> [| 10; 8 |]
   | Ialloc _ -> [| 25; 32 |]
   | Iintoffloat | Ifloatofint
   | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |]
@@ -214,9 +216,9 @@ let max_register_pressure = function
    registers). *)
 
 let op_is_pure = function
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _)
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _)
   | Ispecific(Ishiftcheckbound _) -> false
   | _ -> true
 

diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml
index d7d55a93839ca241d8d60fe7bae64b42e45a3cd3..719c5ec223c50af93043b468f821238f24e050de 100644 (file)
--- a/asmcomp/arm64/selection.ml
+++ b/asmcomp/arm64/selection.ml
@@ -76,10 +76,6 @@ let rec run_automata nbits state input =
 let is_logical_immediate n =
   n <> 0 && n <> -1 && run_automata 64 0 n
 
-let is_intconst = function
-    Cconst_int _ -> true
-  | _ -> false
-
 let inline_ops =
   [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
     "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
@@ -100,7 +96,7 @@ method is_immediate n =
 
 method! is_simple_expr = function
   (* inlined floating-point ops are simple if their arguments are *)
-  | Cop(Cextcall(fn, _, _, _), args) when List.mem fn inline_ops ->
+  | Cop(Cextcall (fn, _, _, _, _), args) when List.mem fn inline_ops ->
       List.for_all self#is_simple_expr args
   | e -> super#is_simple_expr e
 
@@ -183,7 +179,8 @@ method! select_operation op args =
   | Ccheckbound _ ->
       begin match args with
       | [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 ->
-          (Ispecific(Ishiftcheckbound n), [arg1; arg2])
+          (Ispecific(Ishiftcheckbound { shift = n; label_after_error = None; }),
+            [arg1; arg2])
       | _ ->
           super#select_operation op args
       end
@@ -222,15 +219,15 @@ method! select_operation op args =
           super#select_operation op args
       end
   (* Recognize floating-point square root *)
-  | Cextcall("sqrt", _, _, _) ->
+  | Cextcall("sqrt", _, _, _, _) ->
       (Ispecific Isqrtf, args)
   (* Recognize bswap instructions *)
-  | Cextcall("caml_bswap16_direct", _, _, _) ->
+  | Cextcall("caml_bswap16_direct", _, _, _, _) ->
       (Ispecific(Ibswap 16), args)
-  | Cextcall("caml_int32_direct_bswap", _, _, _) ->
+  | Cextcall("caml_int32_direct_bswap", _, _, _, _) ->
       (Ispecific(Ibswap 32), args)
   | Cextcall(("caml_int64_direct_bswap"|"caml_nativeint_direct_bswap"),
-              _, _, _) ->
+              _, _, _, _) ->
       (Ispecific (Ibswap 64), args)
   (* Other operations are regular *)
   | _ ->

diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml
index b365e411c36c0160241288a7d609eb037b1b5bf2..020732dd6684070578fb896b9ef5d03d9c1e2e5f 100644 (file)
--- a/asmcomp/asmgen.ml
+++ b/asmcomp/asmgen.ml
@@ -63,9 +63,9 @@ type clambda_and_constants =
 
 let raw_clambda_dump_if ppf
       ((ulambda, _, structured_constants):clambda_and_constants) =
-  if !dump_rawclambda then
+  if !dump_rawclambda || !dump_clambda then
     begin
-      Format.fprintf ppf "@.clambda (before Un_anf):@.";
+      Format.fprintf ppf "@.clambda:@.";
       Printclambda.clambda ppf ulambda;
       List.iter (fun {Clambda.symbol; definition} ->
           Format.fprintf ppf "%s:@ %a@."
@@ -233,7 +233,7 @@ let lambda_gen_implementation ?toplevel ~source_provenance ppf
   end_gen_implementation ?toplevel ~source_provenance ppf clambda_and_constants
 
 let compile_implementation_gen ?toplevel ~source_provenance prefixname
-    ppf gen_implementation program =
+    ~required_globals ppf gen_implementation program =
   let asmfile =
     if !keep_asm_file || !Emitaux.binary_backend_available
     then prefixname ^ ext_asm
@@ -241,17 +241,19 @@ let compile_implementation_gen ?toplevel ~source_provenance prefixname
   in
   compile_unit ~source_provenance prefixname asmfile !keep_asm_file
       (prefixname ^ ext_obj) (fun () ->
+        Ident.Set.iter Compilenv.require_global required_globals;
         gen_implementation ?toplevel ~source_provenance ppf program)
 
 let compile_implementation_clambda ?toplevel ~source_provenance prefixname
     ppf (program:Lambda.program) =
   compile_implementation_gen ?toplevel ~source_provenance prefixname
+    ~required_globals:program.Lambda.required_globals
     ppf lambda_gen_implementation program
 
 let compile_implementation_flambda ?toplevel ~source_provenance prefixname
-    ~backend ppf (program:Flambda.program) =
+    ~required_globals ~backend ppf (program:Flambda.program) =
   compile_implementation_gen ?toplevel ~source_provenance prefixname
-    ppf (flambda_gen_implementation ~backend) program
+    ~required_globals ppf (flambda_gen_implementation ~backend) program
 
 (* Error report *)
 

diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli
index fc929878cc02275c8b34398bbfc0d1c41918b1fa..cc79edf9af17c4c32f1ef93ac1c637ef552b5a7a 100644 (file)
--- a/asmcomp/asmgen.mli
+++ b/asmcomp/asmgen.mli
@@ -19,6 +19,7 @@ val compile_implementation_flambda :
     ?toplevel:(string -> bool) ->
     source_provenance:Timings.source_provenance ->
     string ->
+    required_globals:Ident.Set.t ->
     backend:(module Backend_intf.S) ->
     Format.formatter -> Flambda.program -> unit
 

diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml
index b5002c186b1ef43c36a1c761f3c599e1a73f406e..ca3f5740f71490d189cb474a6a4dd52906efba64 100644 (file)
--- a/asmcomp/asmlibrarian.ml
+++ b/asmcomp/asmlibrarian.ml
@@ -47,7 +47,7 @@ let read_info name =
   (Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc))
 
 let create_archive file_list lib_name =
-  let archive_name = chop_extension_if_any lib_name ^ ext_lib in
+  let archive_name = Filename.remove_extension lib_name ^ ext_lib in
   let outchan = open_out_bin lib_name in
   try
     output_string outchan cmxa_magic_number;

diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
index 254dec7b8a93c7846a7af51165e55a4acf63f9cc..fee717871290a25ea69c7b48a7e29c0a49a21448 100644 (file)
--- a/asmcomp/asmlink.ml
+++ b/asmcomp/asmlink.ml
@@ -135,7 +135,7 @@ let is_required name =
   try ignore (Hashtbl.find missing_globals name); true
   with Not_found -> false
 
-let add_required by (name, crc) =
+let add_required by (name, _crc) =
   try
     let rq = Hashtbl.find missing_globals name in
     rq := by :: !rq
@@ -233,8 +233,11 @@ let make_startup_file ppf units_list =
           units_list));
   compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list));
   compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list));
-  compile_phrase
-    (Cmmgen.frame_table("_startup" :: "_system" :: name_list));
+  let all_names = "_startup" :: "_system" :: name_list in
+  compile_phrase (Cmmgen.frame_table all_names);
+  if Config.spacetime then begin
+    compile_phrase (Cmmgen.spacetime_shapes all_names);
+  end;
   Emit.end_assembly ()
 
 let make_shared_startup_file ppf units =
@@ -286,9 +289,14 @@ let call_linker file_list startup_file output_name =
   and main_obj_runtime = !Clflags.output_complete_object
   in
   let files = startup_file :: (List.rev file_list) in
+  let libunwind =
+    if not Config.spacetime then []
+    else if not Config.libunwind_available then []
+    else String.split_on_char ' ' Config.libunwind_link_flags
+  in
   let files, c_lib =
     if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then
-      files @ (List.rev !Clflags.ccobjs) @ runtime_lib (),
+      files @ (List.rev !Clflags.ccobjs) @ runtime_lib () @ libunwind,
       (if !Clflags.nopervasives || main_obj_runtime
        then "" else Config.native_c_libraries)
     else

diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml
index 9ecebef8583a847ae96863b1d2c9bc99ef28eac6..6f0db063c6c384efb847809871420f299bef2db2 100644 (file)
--- a/asmcomp/asmpackager.ml
+++ b/asmcomp/asmpackager.ml
@@ -82,7 +82,7 @@ let make_package_object ppf members targetobj targetname coercion
       ~backend =
   let objtemp =
     if !Clflags.keep_asm_file
-    then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj
+    then Filename.remove_extension targetobj ^ ".pack" ^ Config.ext_obj
     else
       (* Put the full name of the module in the temporary file name
          to avoid collisions with MSVC's link /lib in case of successive
@@ -97,12 +97,9 @@ let make_package_object ppf members targetobj targetname coercion
       members in
   let module_ident = Ident.create_persistent targetname in
   let source_provenance = Timings.Pack targetname in
-  let prefixname = chop_extension_if_any objtemp in
+  let prefixname = Filename.remove_extension objtemp in
   if Config.flambda then begin
-    let size, lam =
-      Translmod.transl_package_flambda
-        components module_ident coercion
-    in
+    let size, lam = Translmod.transl_package_flambda components coercion in
     let flam =
       Middle_end.middle_end ppf
         ~source_provenance
@@ -114,17 +111,18 @@ let make_package_object ppf members targetobj targetname coercion
         ~module_initializer:lam
     in
     Asmgen.compile_implementation_flambda ~source_provenance
-      prefixname ~backend ppf flam;
+      prefixname ~backend ~required_globals:Ident.Set.empty ppf flam;
   end else begin
     let main_module_block_size, code =
       Translmod.transl_store_package
         components (Ident.create_persistent targetname) coercion in
     Asmgen.compile_implementation_clambda ~source_provenance
-      prefixname ppf { Lambda.code; main_module_block_size; }
+      prefixname ppf { Lambda.code; main_module_block_size;
+                       module_ident; required_globals = Ident.Set.empty }
   end;
   let objfiles =
     List.map
-      (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj)
+      (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj)
       (List.filter (fun m -> m.pm_kind <> PM_intf) members) in
   let ok =
     Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) ""
@@ -150,7 +148,7 @@ let build_package_cmx members cmxfile =
   let unit_names =
     List.map (fun m -> m.pm_name) members in
   let filter lst =
-    List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in
+    List.filter (fun (name, _crc) -> not (List.mem name unit_names)) lst in
   let union lst =
     List.fold_left
       (List.fold_left
@@ -244,7 +242,7 @@ let package_files ppf initial_env files targetcmx ~backend =
       files in
   let prefix = chop_extensions targetcmx in
   let targetcmi = prefix ^ ".cmi" in
-  let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in
+  let targetobj = Filename.remove_extension targetcmx ^ Config.ext_obj in
   let targetname = String.capitalize_ascii(Filename.basename prefix) in
   (* Set the name of the current "input" *)
   Location.input_name := targetcmx;

diff --git a/asmcomp/branch_relaxation.ml b/asmcomp/branch_relaxation.ml
index 4ef0986534d229fac8b0baf72a2ad187a5b81cd9..6486d19cbcba3ce421925d0d93d76a02674d9f55 100644 (file)
--- a/asmcomp/branch_relaxation.ml
+++ b/asmcomp/branch_relaxation.ml
@@ -51,8 +51,8 @@ module Make (T : Branch_relaxation_intf.S) = struct
       in
       match instr.desc with
       | Lop (Ialloc _)
-      | Lop (Iintop Icheckbound)
-      | Lop (Iintop_imm (Icheckbound, _))
+      | Lop (Iintop (Icheckbound _))
+      | Lop (Iintop_imm (Icheckbound _, _))
       | Lop (Ispecific _) ->
         (* We assume that any branches eligible for relaxation generated
            by these instructions only branch forward.  We further assume
@@ -86,20 +86,21 @@ module Make (T : Branch_relaxation_intf.S) = struct
           fixup did_fix (pc + T.instr_size instr.desc) instr.next
         else
           match instr.desc with
-          | Lop (Ialloc num_words) ->
-            instr.desc <- T.relax_allocation ~num_words;
+          | Lop (Ialloc { words = num_words; label_after_call_gc; }) ->
+            instr.desc <- T.relax_allocation ~num_words ~label_after_call_gc;
             fixup true (pc + T.instr_size instr.desc) instr.next
-          | Lop (Iintop Icheckbound) ->
-            instr.desc <- T.relax_intop_checkbound ();
+          | Lop (Iintop (Icheckbound { label_after_error; })) ->
+            instr.desc <- T.relax_intop_checkbound ~label_after_error;
             fixup true (pc + T.instr_size instr.desc) instr.next
-          | Lop (Iintop_imm (Icheckbound, bound)) ->
-            instr.desc <- T.relax_intop_imm_checkbound ~bound;
+          | Lop (Iintop_imm (Icheckbound { label_after_error; }, bound)) ->
+            instr.desc
+              <- T.relax_intop_imm_checkbound ~bound ~label_after_error;
             fixup true (pc + T.instr_size instr.desc) instr.next
           | Lop (Ispecific specific) ->
             instr.desc <- T.relax_specific_op specific;
             fixup true (pc + T.instr_size instr.desc) instr.next
           | Lcondbranch (test, lbl) ->
-            let lbl2 = new_label() in
+            let lbl2 = Cmm.new_label() in
             let cont =
               instr_cons (Lbranch lbl) [||] [||]
                 (instr_cons (Llabel lbl2) [||] [||] instr.next)

diff --git a/asmcomp/branch_relaxation_intf.ml b/asmcomp/branch_relaxation_intf.ml
index 0bfab4f7e874ee9505176a08f21d37d6f94ac0f4..3b1fbac5db08f147fe346467adfc1f405e1fd994 100644 (file)
--- a/asmcomp/branch_relaxation_intf.ml
+++ b/asmcomp/branch_relaxation_intf.ml
@@ -60,8 +60,16 @@ module type S = sig
   (* Insertion of target-specific code to relax operations that cannot be
      relaxed generically.  It is assumed that these rewrites do not change
      the size of out-of-line code (cf. branch_relaxation.mli). *)
-  val relax_allocation : num_words:int -> Linearize.instruction_desc
-  val relax_intop_checkbound : unit -> Linearize.instruction_desc
-  val relax_intop_imm_checkbound : bound:int -> Linearize.instruction_desc
+  val relax_allocation
+     : num_words:int
+    -> label_after_call_gc:Cmm.label option
+    -> Linearize.instruction_desc
+  val relax_intop_checkbound
+     : label_after_error:Cmm.label option
+    -> Linearize.instruction_desc
+  val relax_intop_imm_checkbound
+     : bound:int
+    -> label_after_error:Cmm.label option
+    -> Linearize.instruction_desc
   val relax_specific_op : Arch.specific_operation -> Linearize.instruction_desc
 end

diff --git a/asmcomp/build_export_info.ml b/asmcomp/build_export_info.ml
index 99d47039f141f6b85660e88eca117a72c4578039..80f97f055f60f2417d824c542a633dcb74461a0a 100644 (file)
--- a/asmcomp/build_export_info.ml
+++ b/asmcomp/build_export_info.ml
@@ -207,7 +207,7 @@ let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx =
     let approx = descr_of_named env defining_expr in
     let env = Env.add_approx env var approx in
     approx_of_expr env body
-  | Let_mutable (_mut_var, _var, body) ->
+  | Let_mutable { body } ->
     approx_of_expr env body
   | Let_rec (defs, body) ->
     let env =
@@ -251,7 +251,7 @@ and descr_of_named (env : Env.t) (named : Flambda.named)
     Value_id (Env.new_descr env (descr_of_constant const))
   | Allocated_const const ->
     Value_id (Env.new_descr env (descr_of_allocated_constant const))
-  | Prim (Pmakeblock (tag, Immutable), args, _dbg) ->
+  | Prim (Pmakeblock (tag, Immutable, _value_kind), args, _dbg) ->
     let approxs = List.map (Env.find_approx env) args in
     let descr : Export_info.descr =
       Value_block (Tag.create_exn tag, Array.of_list approxs)

diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 673bf8c84f0a6194c7dd0a32dac94e0fb2377d59..df4cfc94cb58af963eb5e0ade9689c512117174e 100644 (file)
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -43,7 +43,7 @@ and ulambda =
   | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
   | Uclosure of ufunction list * ulambda list
   | Uoffset of ulambda * int
-  | Ulet of Ident.t * ulambda * ulambda
+  | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
   | Uprim of primitive * ulambda list * Debuginfo.t
   | Uswitch of ulambda * ulambda_switch
@@ -124,7 +124,7 @@ let rec compare_float_lists l1 l2 =
 
 let compare_constants c1 c2 =
   match c1, c2 with
-  | Uconst_ref(lbl1, c1), Uconst_ref(lbl2, c2) -> String.compare lbl1 lbl2
+  | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2
       (* Same labels -> same constants.
          Different labels -> different constants, even if the contents
            match, because of string constants that must not be

diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index f506c7b37ca5d409ded776ab03c1905d04a3a746..dd989cd96481cd680422ddb6def25891266a951e 100644 (file)
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -43,7 +43,7 @@ and ulambda =
   | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
   | Uclosure of ufunction list * ulambda list
   | Uoffset of ulambda * int
-  | Ulet of Ident.t * ulambda * ulambda
+  | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
   | Uprim of primitive * ulambda list * Debuginfo.t
   | Uswitch of ulambda * ulambda_switch

diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index d06e4c6fc88e2c9b073a013906057282ba1640cb..78b7fc3ecf14b8a99ba3578e846e6110c48d008a 100644 (file)
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -50,9 +50,9 @@ let rec build_closure_env env_param pos = function
    and no longer in Cmmgen so that approximations stored in .cmx files
    contain the right names if the -for-pack option is active. *)
 
-let getglobal id =
+let getglobal dbg id =
   Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
-        [], Debuginfo.none)
+        [], dbg)
 
 (* Check if a variable occurs in a [clambda] term. *)
 
@@ -60,14 +60,14 @@ let occurs_var var u =
   let rec occurs = function
       Uvar v -> v = var
     | Uconst _ -> false
-    | Udirect_apply(lbl, args, _) -> List.exists occurs args
+    | Udirect_apply(_lbl, args, _) -> List.exists occurs args
     | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
-    | Uclosure(fundecls, clos) -> List.exists occurs clos
-    | Uoffset(u, ofs) -> occurs u
-    | Ulet(id, def, body) -> occurs def || occurs body
+    | Uclosure(_fundecls, clos) -> List.exists occurs clos
+    | Uoffset(u, _ofs) -> occurs u
+    | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body
     | Uletrec(decls, body) ->
-        List.exists (fun (id, u) -> occurs u) decls || occurs body
-    | Uprim(p, args, _) -> List.exists occurs args
+        List.exists (fun (_id, u) -> occurs u) decls || occurs body
+    | Uprim(_p, args, _) -> List.exists occurs args
     | Uswitch(arg, s) ->
         occurs arg ||
         occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks
@@ -77,12 +77,12 @@ let occurs_var var u =
         (match d with None -> false | Some d -> occurs d)
     | Ustaticfail (_, args) -> List.exists occurs args
     | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr
-    | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr
+    | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr
     | Uifthenelse(cond, ifso, ifnot) ->
         occurs cond || occurs ifso || occurs ifnot
     | Usequence(u1, u2) -> occurs u1 || occurs u2
     | Uwhile(cond, body) -> occurs cond || occurs body
-    | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body
+    | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body
     | Uassign(id, u) -> id = var || occurs u
     | Usend(_, met, obj, args, _) ->
         occurs met || occurs obj || List.exists occurs args
@@ -102,12 +102,12 @@ let occurs_var var u =
 
 let prim_size prim args =
   match prim with
-    Pidentity -> 0
-  | Pgetglobal id -> 1
-  | Psetglobal id -> 1
-  | Pmakeblock(tag, mut) -> 5 + List.length args
-  | Pfield f -> 1
-  | Psetfield(f, isptr, init) ->
+    Pidentity | Pbytes_to_string | Pbytes_of_string -> 0
+  | Pgetglobal _ -> 1
+  | Psetglobal _ -> 1
+  | Pmakeblock _ -> 5 + List.length args
+  | Pfield _ -> 1
+  | Psetfield(_f, isptr, init) ->
     begin match init with
     | Initialization -> 1  (* never causes a write barrier hit *)
     | Assignment ->
@@ -115,13 +115,15 @@ let prim_size prim args =
       | Pointer -> 4
       | Immediate -> 1
     end
-  | Pfloatfield f -> 1
-  | Psetfloatfield (f, _) -> 1
+  | Pfloatfield _ -> 1
+  | Psetfloatfield _ -> 1
   | Pduprecord _ -> 10 + List.length args
   | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
   | Praise _ -> 4
   | Pstringlength -> 5
-  | Pstringrefs | Pstringsets -> 6
+  | Pbyteslength -> 5
+  | Pstringrefs  -> 6
+  | Pbytesrefs | Pbytessets -> 6
   | Pmakearray _ -> 5 + List.length args
   | Parraylength kind -> if kind = Pgenarray then 6 else 2
   | Parrayrefu kind -> if kind = Pgenarray then 12 else 2
@@ -140,19 +142,19 @@ let lambda_smaller lam threshold =
   let rec lambda_size lam =
     if !size > threshold then raise Exit;
     match lam with
-      Uvar v -> ()
+      Uvar _ -> ()
     | Uconst _ -> incr size
-    | Udirect_apply(fn, args, _) ->
+    | Udirect_apply(_, args, _) ->
         size := !size + 4; lambda_list_size args
     | Ugeneric_apply(fn, args, _) ->
         size := !size + 6; lambda_size fn; lambda_list_size args
-    | Uclosure(defs, vars) ->
+    | Uclosure _ ->
         raise Exit (* inlining would duplicate function definitions *)
-    | Uoffset(lam, ofs) ->
+    | Uoffset(lam, _ofs) ->
         incr size; lambda_size lam
-    | Ulet(id, lam, body) ->
+    | Ulet(_str, _kind, _id, lam, body) ->
         lambda_size lam; lambda_size body
-    | Uletrec(bindings, body) ->
+    | Uletrec _ ->
         raise Exit (* usually too large *)
     | Uprim(prim, args, _) ->
         size := !size + prim_size prim args;
@@ -175,7 +177,7 @@ let lambda_smaller lam threshold =
     | Ustaticfail (_,args) -> lambda_list_size args
     | Ucatch(_, _, body, handler) ->
         incr size; lambda_size body; lambda_size handler
-    | Utrywith(body, id, handler) ->
+    | Utrywith(body, _id, handler) ->
         size := !size + 8; lambda_size body; lambda_size handler
     | Uifthenelse(cond, ifso, ifnot) ->
         size := !size + 2;
@@ -184,9 +186,9 @@ let lambda_smaller lam threshold =
         lambda_size lam1; lambda_size lam2
     | Uwhile(cond, body) ->
         size := !size + 2; lambda_size cond; lambda_size body
-    | Ufor(id, low, high, dir, body) ->
+    | Ufor(_id, low, high, _dir, body) ->
         size := !size + 4; lambda_size low; lambda_size high; lambda_size body
-    | Uassign(id, lam) ->
+    | Uassign(_id, lam) ->
         incr size;  lambda_size lam
     | Usend(_, met, obj, args, _) ->
         size := !size + 8;
@@ -203,12 +205,12 @@ let lambda_smaller lam threshold =
    that is without side-effects *and* not containing function definitions *)
 
 let rec is_pure_clambda = function
-    Uvar v -> true
+    Uvar _ -> true
   | Uconst _ -> true
   | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
-           Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
+           Pccall _ | Praise _ | Poffsetref _ |  Pbytessetu | Pbytessets |
            Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
-  | Uprim(p, args, _) -> List.for_all is_pure_clambda args
+  | Uprim(_, args, _) -> List.for_all is_pure_clambda args
   | _ -> false
 
 (* Simplify primitive operations on known arguments *)
@@ -263,8 +265,8 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
       | Paddint -> make_const_int (n1 + n2)
       | Psubint -> make_const_int (n1 - n2)
       | Pmulint -> make_const_int (n1 * n2)
-      | Pdivint when n2 <> 0 -> make_const_int (n1 / n2)
-      | Pmodint when n2 <> 0 -> make_const_int (n1 mod n2)
+      | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2)
+      | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2)
       | Pandint -> make_const_int (n1 land n2)
       | Porint -> make_const_int (n1 lor n2)
       | Pxorint -> make_const_int (n1 lxor n2)
@@ -312,9 +314,9 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
       | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2)
       | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2)
       | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2)
-      | Pdivbint Pnativeint when n2 <> 0n ->
+      | Pdivbint {size=Pnativeint} when n2 <> 0n ->
           make_const_natint (Nativeint.div n1 n2)
-      | Pmodbint Pnativeint when n2 <> 0n ->
+      | Pmodbint {size=Pnativeint} when n2 <> 0n ->
           make_const_natint (Nativeint.rem n1 n2)
       | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2)
       | Porbint Pnativeint ->  make_const_natint (Nativeint.logor n1 n2)
@@ -350,8 +352,10 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
       | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2)
       | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2)
       | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2)
-      | Pdivbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.div n1 n2)
-      | Pmodbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.rem n1 n2)
+      | Pdivbint {size=Pint32} when n2 <> 0l ->
+          make_const_int32 (Int32.div n1 n2)
+      | Pmodbint {size=Pint32} when n2 <> 0l ->
+          make_const_int32 (Int32.rem n1 n2)
       | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2)
       | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2)
       | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2)
@@ -386,8 +390,10 @@ let simplif_arith_prim_pure fpc p (args, approxs) dbg =
       | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2)
       | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2)
       | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2)
-      | Pdivbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.div n1 n2)
-      | Pmodbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.rem n1 n2)
+      | Pdivbint {size=Pint64} when n2 <> 0L ->
+          make_const_int64 (Int64.div n1 n2)
+      | Pmodbint {size=Pint64} when n2 <> 0L ->
+          make_const_int64 (Int64.rem n1 n2)
       | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2)
       | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2)
       | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2)
@@ -421,7 +427,7 @@ let field_approx n = function
 let simplif_prim_pure fpc p (args, approxs) dbg =
   match p, args, approxs with
   (* Block construction *)
-  | Pmakeblock(tag, Immutable), _, _ ->
+  | Pmakeblock(tag, Immutable, _kind), _, _ ->
       let field = function
         | Value_const c -> c
         | _ -> raise Exit
@@ -443,10 +449,12 @@ let simplif_prim_pure fpc p (args, approxs) dbg =
     when n < List.length ul ->
       (List.nth ul n, field_approx n approx)
   (* Strings *)
-  | Pstringlength, _, [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->
+  | (Pstringlength | Pbyteslength),
+     _,
+     [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->
       make_const_int (String.length s)
   (* Identity *)
-  | Pidentity, [arg1], [app1] ->
+  | (Pidentity | Pbytes_to_string | Pbytes_of_string), [arg1], [app1] ->
       (arg1, app1)
   (* Kind test *)
   | Pisint, _, [a1] ->
@@ -466,6 +474,8 @@ let simplif_prim_pure fpc p (args, approxs) dbg =
         | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
         | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
         | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
+        | Backend_type ->
+            make_const_ptr 0 (* tag 0 is the same as Native here *)
       end
   (* Catch-all *)
   | _ ->
@@ -478,7 +488,7 @@ let simplif_prim fpc p (args, approxs as args_approxs) dbg =
     (* XXX : always return the same approxs as simplif_prim_pure? *)
     let approx =
       match p with
-      | Pmakeblock(_, Immutable) ->
+      | Pmakeblock(_, Immutable, _kind) ->
           Value_tuple (Array.of_list approxs)
       | _ ->
           Value_unknown
@@ -507,17 +517,24 @@ let find_action idxs acts tag =
     (* Can this happen? *)
     None
 
+let subst_debuginfo loc dbg =
+  if !Clflags.debug then
+    Debuginfo.inline loc dbg
+  else
+    dbg
 
-let rec substitute fpc sb ulam =
+let rec substitute loc fpc sb ulam =
   match ulam with
     Uvar v ->
       begin try Tbl.find v sb with Not_found -> ulam end
   | Uconst _ -> ulam
   | Udirect_apply(lbl, args, dbg) ->
-      Udirect_apply(lbl, List.map (substitute fpc sb) args, dbg)
+      let dbg = subst_debuginfo loc dbg in
+      Udirect_apply(lbl, List.map (substitute loc fpc sb) args, dbg)
   | Ugeneric_apply(fn, args, dbg) ->
-      Ugeneric_apply(substitute fpc sb fn,
-                     List.map (substitute fpc sb) args, dbg)
+      let dbg = subst_debuginfo loc dbg in
+      Ugeneric_apply(substitute loc fpc sb fn,
+                     List.map (substitute loc fpc sb) args, dbg)
   | Uclosure(defs, env) ->
       (* Question: should we rename function labels as well?  Otherwise,
          there is a risk that function labels are not globally unique.
@@ -527,12 +544,12 @@ let rec substitute fpc sb ulam =
          - When we substitute offsets for idents bound by let rec
            in [close], case [Lletrec], we discard the original
            let rec body and use only the substituted term. *)
-      Uclosure(defs, List.map (substitute fpc sb) env)
-  | Uoffset(u, ofs) -> Uoffset(substitute fpc sb u, ofs)
-  | Ulet(id, u1, u2) ->
+      Uclosure(defs, List.map (substitute loc fpc sb) env)
+  | Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb u, ofs)
+  | Ulet(str, kind, id, u1, u2) ->
       let id' = Ident.rename id in
-      Ulet(id', substitute fpc sb u1,
-           substitute fpc (Tbl.add id (Uvar id') sb) u2)
+      Ulet(str, kind, id', substitute loc fpc sb u1,
+           substitute loc fpc (Tbl.add id (Uvar id') sb) u2)
   | Uletrec(bindings, body) ->
       let bindings1 =
         List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
@@ -542,17 +559,17 @@ let rec substitute fpc sb ulam =
           bindings1 sb in
       Uletrec(
         List.map
-           (fun (id, id', rhs) -> (id', substitute fpc sb' rhs))
+           (fun (_id, id', rhs) -> (id', substitute loc fpc sb' rhs))
            bindings1,
-        substitute fpc sb' body)
+        substitute loc fpc sb' body)
   | Uprim(p, args, dbg) ->
-      let sargs =
-        List.map (substitute fpc sb) args in
+      let sargs = List.map (substitute loc fpc sb) args in
+      let dbg = subst_debuginfo loc dbg in
       let (res, _) =
         simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in
       res
   | Uswitch(arg, sw) ->
-      let sarg = substitute fpc sb arg in
+      let sarg = substitute loc fpc sb arg in
       let action =
         (* Unfortunately, we cannot easily deal with the
            case of a constructed block (makeblock) bound to a local
@@ -568,23 +585,23 @@ let rec substitute fpc sb ulam =
         | _ -> None
       in
       begin match action with
-      | Some u -> substitute fpc sb u
+      | Some u -> substitute loc fpc sb u
       | None ->
           Uswitch(sarg,
                   { sw with
                     us_actions_consts =
-                      Array.map (substitute fpc sb) sw.us_actions_consts;
+                      Array.map (substitute loc fpc sb) sw.us_actions_consts;
                     us_actions_blocks =
-                      Array.map (substitute fpc sb) sw.us_actions_blocks;
+                      Array.map (substitute loc fpc sb) sw.us_actions_blocks;
                   })
       end
   | Ustringswitch(arg,sw,d) ->
       Ustringswitch
-        (substitute fpc sb arg,
-         List.map (fun (s,act) -> s,substitute fpc sb act) sw,
-         Misc.may_map (substitute fpc sb) d)
+        (substitute loc fpc sb arg,
+         List.map (fun (s,act) -> s,substitute loc fpc sb act) sw,
+         Misc.may_map (substitute loc fpc sb) d)
   | Ustaticfail (nfail, args) ->
-      Ustaticfail (nfail, List.map (substitute fpc sb) args)
+      Ustaticfail (nfail, List.map (substitute loc fpc sb) args)
   | Ucatch(nfail, ids, u1, u2) ->
       let ids' = List.map Ident.rename ids in
       let sb' =
@@ -592,38 +609,39 @@ let rec substitute fpc sb ulam =
           (fun id id' s -> Tbl.add id (Uvar id') s)
           ids ids' sb
       in
-      Ucatch(nfail, ids', substitute fpc sb u1, substitute fpc sb' u2)
+      Ucatch(nfail, ids', substitute loc fpc sb u1, substitute loc fpc sb' u2)
   | Utrywith(u1, id, u2) ->
       let id' = Ident.rename id in
-      Utrywith(substitute fpc sb u1, id',
-               substitute fpc (Tbl.add id (Uvar id') sb) u2)
+      Utrywith(substitute loc fpc sb u1, id',
+               substitute loc fpc (Tbl.add id (Uvar id') sb) u2)
   | Uifthenelse(u1, u2, u3) ->
-      begin match substitute fpc sb u1 with
+      begin match substitute loc fpc sb u1 with
         Uconst (Uconst_ptr n) ->
-          if n <> 0 then substitute fpc sb u2 else substitute fpc sb u3
+          if n <> 0 then substitute loc fpc sb u2 else substitute loc fpc sb u3
       | Uprim(Pmakeblock _, _, _) ->
-          substitute fpc sb u2
+          substitute loc fpc sb u2
       | su1 ->
-          Uifthenelse(su1, substitute fpc sb u2, substitute fpc sb u3)
+          Uifthenelse(su1, substitute loc fpc sb u2, substitute loc fpc sb u3)
       end
   | Usequence(u1, u2) ->
-      Usequence(substitute fpc sb u1, substitute fpc sb u2)
+      Usequence(substitute loc fpc sb u1, substitute loc fpc sb u2)
   | Uwhile(u1, u2) ->
-      Uwhile(substitute fpc sb u1, substitute fpc sb u2)
+      Uwhile(substitute loc fpc sb u1, substitute loc fpc sb u2)
   | Ufor(id, u1, u2, dir, u3) ->
       let id' = Ident.rename id in
-      Ufor(id', substitute fpc sb u1, substitute fpc sb u2, dir,
-           substitute fpc (Tbl.add id (Uvar id') sb) u3)
+      Ufor(id', substitute loc fpc sb u1, substitute loc fpc sb u2, dir,
+           substitute loc fpc (Tbl.add id (Uvar id') sb) u3)
   | Uassign(id, u) ->
       let id' =
         try
           match Tbl.find id sb with Uvar i -> i | _ -> assert false
         with Not_found ->
           id in
-      Uassign(id', substitute fpc sb u)
+      Uassign(id', substitute loc fpc sb u)
   | Usend(k, u1, u2, ul, dbg) ->
-      Usend(k, substitute fpc sb u1, substitute fpc sb u2,
-            List.map (substitute fpc sb) ul, dbg)
+      let dbg = subst_debuginfo loc dbg in
+      Usend(k, substitute loc fpc sb u1, substitute loc fpc sb u2,
+            List.map (substitute loc fpc sb) ul, dbg)
   | Uunreachable ->
       Uunreachable
 
@@ -637,50 +655,51 @@ let no_effects = function
   | Uclosure _ -> true
   | u -> is_simple_argument u
 
-let rec bind_params_rec fpc subst params args body =
+let rec bind_params_rec loc fpc subst params args body =
   match (params, args) with
-    ([], []) -> substitute fpc subst body
+    ([], []) -> substitute loc fpc subst body
   | (p1 :: pl, a1 :: al) ->
       if is_simple_argument a1 then
-        bind_params_rec fpc (Tbl.add p1 a1 subst) pl al body
+        bind_params_rec loc fpc (Tbl.add p1 a1 subst) pl al body
       else begin
         let p1' = Ident.rename p1 in
         let u1, u2 =
           match Ident.name p1, a1 with
-          | "*opt*", Uprim(Pmakeblock(0, Immutable), [a], dbg) ->
-              a, Uprim(Pmakeblock(0, Immutable), [Uvar p1'], dbg)
+          | "*opt*", Uprim(Pmakeblock(0, Immutable, kind), [a], dbg) ->
+              a, Uprim(Pmakeblock(0, Immutable, kind), [Uvar p1'], dbg)
           | _ ->
               a1, Uvar p1'
         in
         let body' =
-          bind_params_rec fpc (Tbl.add p1 u2 subst) pl al body in
-        if occurs_var p1 body then Ulet(p1', u1, body')
+          bind_params_rec loc fpc (Tbl.add p1 u2 subst) pl al body in
+        if occurs_var p1 body then Ulet(Immutable, Pgenval, p1', u1, body')
         else if no_effects a1 then body'
         else Usequence(a1, body')
       end
   | (_, _) -> assert false
 
-let bind_params fpc params args body =
+let bind_params loc fpc params args body =
   (* Reverse parameters and arguments to preserve right-to-left
      evaluation order (PR#2910). *)
-  bind_params_rec fpc Tbl.empty (List.rev params) (List.rev args) body
+  bind_params_rec loc fpc Tbl.empty (List.rev params) (List.rev args) body
 
 (* Check if a lambda term is ``pure'',
    that is without side-effects *and* not containing function definitions *)
 
 let rec is_pure = function
-    Lvar v -> true
-  | Lconst cst -> true
+    Lvar _ -> true
+  | Lconst _ -> true
   | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
-           Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
-           Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false
-  | Lprim(p, args) -> List.for_all is_pure args
-  | Levent(lam, ev) -> is_pure lam
+           Pccall _ | Praise _ | Poffsetref _  | Pbytessetu | Pbytessets |
+           Parraysetu _ | Parraysets _ | Pbigarrayset _), _,_) -> false
+  | Lprim(_, args,_) -> List.for_all is_pure args
+  | Levent(lam, _ev) -> is_pure lam
   | _ -> false
 
 let warning_if_forced_inline ~loc ~attribute warning =
   if attribute = Always_inline then
-    Location.prerr_warning loc (Warnings.Inlining_impossible warning)
+    Location.prerr_warning loc
+      (Warnings.Inlining_impossible warning)
 
 (* Generate a direct application *)
 
@@ -690,11 +709,12 @@ let direct_apply fundesc funct ufunct uargs ~loc ~attribute =
   let app =
     match fundesc.fun_inline, attribute with
     | _, Never_inline | None, _ ->
+      let dbg = Debuginfo.from_location loc in
         warning_if_forced_inline ~loc ~attribute
           "Function information unavailable";
-        Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none)
+        Udirect_apply(fundesc.fun_label, app_args, dbg)
     | Some(params, body), _  ->
-        bind_params fundesc.fun_float_const_prop params app_args body
+        bind_params loc fundesc.fun_float_const_prop params app_args body
   in
   (* If ufunct can contain side-effects or function definitions,
      we must make sure that it is evaluated exactly once.
@@ -746,32 +766,6 @@ let global_approx = ref([||] : value_approximation array)
 let function_nesting_depth = ref 0
 let excessive_function_nesting_depth = 5
 
-(* Decorate clambda term with debug information *)
-
-let rec add_debug_info ev u =
-  match ev.lev_kind with
-  | Lev_after _ ->
-      begin match u with
-      | Udirect_apply(lbl, args, dinfo) ->
-          Udirect_apply(lbl, args, Debuginfo.from_call ev)
-      | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1),
-                       args2, dinfo2) ->
-          Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev),
-                         args2, Debuginfo.from_call ev)
-      | Ugeneric_apply(fn, args, dinfo) ->
-          Ugeneric_apply(fn, args, Debuginfo.from_call ev)
-      | Uprim(Praise k, args, dinfo) ->
-          Uprim(Praise k, args, Debuginfo.from_call ev)
-      | Uprim(p, args, dinfo) ->
-          Uprim(p, args, Debuginfo.from_call ev)
-      | Usend(kind, u1, u2, args, dinfo) ->
-          Usend(kind, u1, u2, args, Debuginfo.from_call ev)
-      | Usequence(u1, u2) ->
-          Usequence(u1, add_debug_info ev u2)
-      | _ -> u
-      end
-  | _ -> u
-
 (* Uncurry an expression and explicitate closures.
    Also return the approximation of the expression.
    The approximation environment [fenv] maps idents to approximations.
@@ -790,7 +784,7 @@ let close_approx_var fenv cenv id =
       (subst, approx)
 
 let close_var fenv cenv id =
-  let (ulam, app) = close_approx_var fenv cenv id in ulam
+  let (ulam, _app) = close_approx_var fenv cenv id in ulam
 
 let rec close fenv cenv = function
     Lvar id ->
@@ -814,16 +808,20 @@ let rec close fenv cenv = function
         | Const_immstring s ->
             str (Uconst_string s)
         | Const_base (Const_string (s, _)) ->
-              (* strings (even literal ones) are mutable! *)
-              (* of course, the empty string is really immutable *)
-            str ~shared:false(*(String.length s = 0)*) (Uconst_string s)
+              (* Strings (even literal ones) must be assumed to be mutable...
+                 except when OCaml has been configured with
+                 -safe-string.  Passing -safe-string at compilation
+                 time is not enough, since the unit could be linked
+                 with another one compiled without -safe-string, and
+                 that one could modify our string literal.  *)
+            str ~shared:Config.safe_string (Uconst_string s)
         | Const_base(Const_float x) -> str (Uconst_float (float_of_string x))
         | Const_base(Const_int32 x) -> str (Uconst_int32 x)
         | Const_base(Const_int64 x) -> str (Uconst_int64 x)
         | Const_base(Const_nativeint x) -> str (Uconst_nativeint x)
       in
       make_const (transl cst)
-  | Lfunction{kind; params; body} as funct ->
+  | Lfunction _ as funct ->
       close_one_function fenv cenv (Ident.create "fun") funct
 
     (* We convert [f a] to [let a' = a in fun b c -> f a' b c]
@@ -833,16 +831,18 @@ let rec close fenv cenv = function
       let nargs = List.length args in
       begin match (close fenv cenv funct, close_list fenv cenv args) with
         ((ufunct, Value_closure(fundesc, approx_res)),
-         [Uprim(Pmakeblock(_, _), uargs, _)])
+         [Uprim(Pmakeblock _, uargs, _)])
         when List.length uargs = - fundesc.fun_arity ->
-          let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in
+          let app =
+            direct_apply ~loc ~attribute fundesc funct ufunct uargs in
           (app, strengthen_approx app approx_res)
       | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
         when nargs = fundesc.fun_arity ->
-          let app = direct_apply ~loc ~attribute fundesc funct ufunct uargs in
+          let app =
+            direct_apply ~loc ~attribute fundesc funct ufunct uargs in
           (app, strengthen_approx app approx_res)
 
-      | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
+      | ((_ufunct, Value_closure(fundesc, _approx_res)), uargs)
           when nargs < fundesc.fun_arity ->
         let first_args = List.map (fun arg ->
           (Ident.create "arg", arg) ) uargs in
@@ -854,10 +854,10 @@ let rec close fenv cenv = function
               [] -> body
             | (arg1, arg2) :: args ->
               iter args
-                (Ulet ( arg1, arg2, body))
+                (Ulet (Immutable, Pgenval, arg1, arg2, body))
         in
         let internal_args =
-          (List.map (fun (arg1, arg2) -> Lvar arg1) first_args)
+          (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args)
           @ (List.map (fun arg -> Lvar arg ) final_args)
         in
         let (new_fun, approx) = close fenv cenv
@@ -870,44 +870,49 @@ let rec close fenv cenv = function
                              ap_args=internal_args;
                              ap_inlined=Default_inline;
                              ap_specialised=Default_specialise};
+               loc;
                attr = default_function_attribute})
         in
         let new_fun = iter first_args new_fun in
         warning_if_forced_inline ~loc ~attribute "Partial application";
         (new_fun, approx)
 
-      | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
+      | ((ufunct, Value_closure(fundesc, _approx_res)), uargs)
         when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
           let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
+          let dbg = Debuginfo.from_location loc in
           warning_if_forced_inline ~loc ~attribute "Over-application";
-          (Ugeneric_apply(direct_apply ~loc ~attribute fundesc funct ufunct
-                          first_args, rem_args, Debuginfo.none),
+          (Ugeneric_apply(direct_apply ~loc ~attribute
+                            fundesc funct ufunct first_args,
+                          rem_args, dbg),
            Value_unknown)
       | ((ufunct, _), uargs) ->
+          let dbg = Debuginfo.from_location loc in
           warning_if_forced_inline ~loc ~attribute "Unknown function";
-          (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
+          (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown)
       end
-  | Lsend(kind, met, obj, args, _) ->
+  | Lsend(kind, met, obj, args, loc) ->
       let (umet, _) = close fenv cenv met in
       let (uobj, _) = close fenv cenv obj in
-      (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none),
+      let dbg = Debuginfo.from_location loc in
+      (Usend(kind, umet, uobj, close_list fenv cenv args, dbg),
        Value_unknown)
-  | Llet(str, id, lam, body) ->
+  | Llet(str, kind, id, lam, body) ->
       let (ulam, alam) = close_named fenv cenv id lam in
       begin match (str, alam) with
         (Variable, _) ->
           let (ubody, abody) = close fenv cenv body in
-          (Ulet(id, ulam, ubody), abody)
+          (Ulet(Mutable, kind, id, ulam, ubody), abody)
       | (_, Value_const _)
         when str = Alias || is_pure lam ->
           close (Tbl.add id alam fenv) cenv body
       | (_, _) ->
           let (ubody, abody) = close (Tbl.add id alam fenv) cenv body in
-          (Ulet(id, ulam, ubody), abody)
+          (Ulet(Immutable, kind, id, ulam, ubody), abody)
       end
   | Lletrec(defs, body) ->
       if List.for_all
-           (function (id, Lfunction _) -> true | _ -> false)
+           (function (_id, Lfunction _) -> true | _ -> false)
            defs
       then begin
         (* Simple case: only function definitions *)
@@ -915,15 +920,16 @@ let rec close fenv cenv = function
         let clos_ident = Ident.create "clos" in
         let fenv_body =
           List.fold_right
-            (fun (id, pos, approx) fenv -> Tbl.add id approx fenv)
+            (fun (id, _pos, approx) fenv -> Tbl.add id approx fenv)
             infos fenv in
         let (ubody, approx) = close fenv_body cenv body in
         let sb =
           List.fold_right
-            (fun (id, pos, approx) sb ->
+            (fun (id, pos, _approx) sb ->
               Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
             infos Tbl.empty in
-        (Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody),
+        (Ulet(Immutable, Pgenval, clos_ident, clos,
+              substitute Location.none !Clflags.float_const_prop sb ubody),
          approx)
       end else begin
         (* General case: recursive definition of values *)
@@ -937,42 +943,47 @@ let rec close fenv cenv = function
         let (ubody, approx) = close fenv_body cenv body in
         (Uletrec(udefs, ubody), approx)
       end
-  | Lprim(Pdirapply loc,[funct;arg])
-  | Lprim(Prevapply loc,[arg;funct]) ->
+  | Lprim(Pdirapply,[funct;arg], loc)
+  | Lprim(Prevapply,[arg;funct], loc) ->
       close fenv cenv (Lapply{ap_should_be_tailcall=false;
                               ap_loc=loc;
                               ap_func=funct;
                               ap_args=[arg];
                               ap_inlined=Default_inline;
                               ap_specialised=Default_specialise})
-  | Lprim(Pgetglobal id, []) as lam ->
+  | Lprim(Pgetglobal id, [], loc) as lam ->
+      let dbg = Debuginfo.from_location loc in
       check_constant_result lam
-                            (getglobal id)
+                            (getglobal dbg id)
                             (Compilenv.global_approx id)
-  | Lprim(Pfield n, [lam]) ->
+  | Lprim(Pfield n, [lam], loc) ->
       let (ulam, approx) = close fenv cenv lam in
-      check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none))
+      let dbg = Debuginfo.from_location loc in
+      check_constant_result lam (Uprim(Pfield n, [ulam], dbg))
                             (field_approx n approx)
-  | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, []); lam]) ->
+  | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->
       let (ulam, approx) = close fenv cenv lam in
       if approx <> Value_unknown then
         (!global_approx).(n) <- approx;
-      (Uprim(Psetfield(n, is_ptr, init), [getglobal id; ulam], Debuginfo.none),
+      let dbg = Debuginfo.from_location loc in
+      (Uprim(Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg),
        Value_unknown)
-  | Lprim(Praise k, [Levent(arg, ev)]) ->
-      let (ulam, approx) = close fenv cenv arg in
-      (Uprim(Praise k, [ulam], Debuginfo.from_raise ev),
+  | Lprim(Praise k, [arg], loc) ->
+      let (ulam, _approx) = close fenv cenv arg in
+      let dbg = Debuginfo.from_location loc in
+      (Uprim(Praise k, [ulam], dbg),
        Value_unknown)
-  | Lprim(p, args) ->
+  | Lprim(p, args, loc) ->
+      let dbg = Debuginfo.from_location loc in
       simplif_prim !Clflags.float_const_prop
-                   p (close_list_approx fenv cenv args) Debuginfo.none
+                   p (close_list_approx fenv cenv args) dbg
   | Lswitch(arg, sw) ->
       let fn fail =
         let (uarg, _) = close fenv cenv arg in
         let const_index, const_actions, fconst =
-          close_switch arg fenv cenv sw.sw_consts sw.sw_numconsts fail
+          close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail
         and block_index, block_actions, fblock =
-          close_switch arg fenv cenv sw.sw_blocks sw.sw_numblocks fail in
+          close_switch fenv cenv sw.sw_blocks sw.sw_numblocks fail in
         let ulam =
           Uswitch
             (uarg,
@@ -996,7 +1007,7 @@ let rec close fenv cenv = function
             Ucatch (i,[],ubody,uhandler),Value_unknown
           else fn fail
       end
-  | Lstringswitch(arg,sw,d) ->
+  | Lstringswitch(arg,sw,d,_) ->
       let uarg,_ = close fenv cenv arg in
       let usw =
         List.map
@@ -1046,9 +1057,8 @@ let rec close fenv cenv = function
   | Lassign(id, lam) ->
       let (ulam, _) = close fenv cenv lam in
       (Uassign(id, ulam), Value_unknown)
-  | Levent(lam, ev) ->
-      let (ulam, approx) = close fenv cenv lam in
-      (add_debug_info ev ulam, approx)
+  | Levent(lam, _) ->
+      close fenv cenv lam
   | Lifused _ ->
       assert false
 
@@ -1066,7 +1076,7 @@ and close_list_approx fenv cenv = function
       (ulam :: ulams, approx :: approxs)
 
 and close_named fenv cenv id = function
-    Lfunction{kind; params; body} as funct ->
+    Lfunction _ as funct ->
       close_one_function fenv cenv id funct
   | lam ->
       close fenv cenv lam
@@ -1078,14 +1088,15 @@ and close_functions fenv cenv fun_defs =
     List.flatten
       (List.map
          (function
-           | (id, Lfunction{kind; params; body; attr}) ->
-               Simplif.split_default_wrapper id kind params body attr
+           | (id, Lfunction{kind; params; body; attr; loc}) ->
+               Simplif.split_default_wrapper ~id ~kind ~params
+                 ~body ~attr ~wrapper_attr:attr ~loc ()
            | _ -> assert false
          )
          fun_defs)
   in
   let inline_attribute = match fun_defs with
-    | [_, Lfunction{kind; params; body; attr = { inline }}] -> inline
+    | [_, Lfunction{attr = { inline }}] -> inline
     | _ -> Default_inline (* recursive functions can't be inlined *)
   in
 
@@ -1102,7 +1113,7 @@ and close_functions fenv cenv fun_defs =
   let uncurried_defs =
     List.map
       (function
-          (id, Lfunction{kind; params; body}) ->
+          (id, Lfunction{kind; params; body; loc}) ->
             let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in
             let arity = List.length params in
             let fundesc =
@@ -1111,20 +1122,21 @@ and close_functions fenv cenv fun_defs =
                fun_closed = initially_closed;
                fun_inline = None;
                fun_float_const_prop = !Clflags.float_const_prop } in
-            (id, params, body, fundesc)
+            let dbg = Debuginfo.from_location loc in
+            (id, params, body, fundesc, dbg)
         | (_, _) -> fatal_error "Closure.close_functions")
       fun_defs in
   (* Build an approximate fenv for compiling the functions *)
   let fenv_rec =
     List.fold_right
-      (fun (id, params, body, fundesc) fenv ->
+      (fun (id, _params, _body, fundesc, _dbg) fenv ->
         Tbl.add id (Value_closure(fundesc, Value_unknown)) fenv)
       uncurried_defs fenv in
   (* Determine the offsets of each function's closure in the shared block *)
   let env_pos = ref (-1) in
   let clos_offsets =
     List.map
-      (fun (id, params, body, fundesc) ->
+      (fun (_id, _params, _body, fundesc, _dbg) ->
         let pos = !env_pos + 1 in
         env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
         pos)
@@ -1134,16 +1146,13 @@ and close_functions fenv cenv fun_defs =
      does not use its environment parameter is invalidated. *)
   let useless_env = ref initially_closed in
   (* Translate each function definition *)
-  let clos_fundef (id, params, body, fundesc) env_pos =
-    let dbg = match body with
-      | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev
-      | _ -> Debuginfo.none in
+  let clos_fundef (id, params, body, fundesc, dbg) env_pos =
     let env_param = Ident.create "env" in
     let cenv_fv =
       build_closure_env env_param (fv_pos - env_pos) fv in
     let cenv_body =
       List.fold_right2
-        (fun (id, params, body, fundesc) pos env ->
+        (fun (id, _params, _body, _fundesc, _dbg) pos env ->
           Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
         uncurried_defs clos_offsets cenv_fv in
     let (ubody, approx) = close fenv_rec cenv_body body in
@@ -1193,7 +1202,7 @@ and close_functions fenv cenv fun_defs =
          recompile *)
         Compilenv.backtrack snap; (* PR#6337 *)
         List.iter
-          (fun (id, params, body, fundesc) ->
+          (fun (_id, _params, _body, fundesc, _dbg) ->
              fundesc.fun_closed <- false;
              fundesc.fun_inline <- None;
           )
@@ -1221,7 +1230,7 @@ and close_one_function fenv cenv id funct =
 
 (* Close a switch *)
 
-and close_switch arg fenv cenv cases num_keys default =
+and close_switch fenv cenv cases num_keys default =
   let ncases = List.length cases in
   let index = Array.make num_keys 0
   and store = Storer.mk_store () in
@@ -1287,7 +1296,7 @@ let collect_exported_structured_constants a =
     | Uconst_ref (s, (Some c)) ->
         Compilenv.add_exported_constant s;
         structured_constant c
-    | Uconst_ref (s, None) -> assert false (* Cannot be generated *)
+    | Uconst_ref (_s, None) -> assert false (* Cannot be generated *)
     | Uconst_int _ | Uconst_ptr _ -> ()
   and structured_constant = function
     | Uconst_block (_, ul) -> List.iter const ul
@@ -1304,7 +1313,7 @@ let collect_exported_structured_constants a =
         List.iter (fun f -> ulam f.body) fl;
         List.iter ulam ul
     | Uoffset(u, _) -> ulam u
-    | Ulet (_, u1, u2) -> ulam u1; ulam u2
+    | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2
     | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u
     | Uprim (_, ul, _) -> List.iter ulam ul
     | Uswitch (u, sl) ->
@@ -1339,7 +1348,7 @@ let intro size lam =
   let id = Compilenv.make_symbol None in
   global_approx := Array.init size (fun i -> Value_global_field (id, i));
   Compilenv.set_global_approx(Value_tuple !global_approx);
-  let (ulam, approx) = close Tbl.empty Tbl.empty lam in
+  let (ulam, _approx) = close Tbl.empty Tbl.empty lam in
   let opaque =
     !Clflags.opaque
     || Env.is_imported_opaque (Compilenv.current_unit_name ())

diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
index 9243cb47afa8ad85b6abde88d8c247e99590c347..eb920b28e689210556e88b539eb82fbe58f362d1 100644 (file)
--- a/asmcomp/cmm.ml
+++ b/asmcomp/cmm.ml
@@ -107,6 +107,16 @@ let swap_comparison = function
   | Clt -> Cgt | Cle -> Cge
   | Cgt -> Clt | Cge -> Cle
 
+type label = int
+
+let label_counter = ref 99
+
+let new_label() = incr label_counter; !label_counter
+
+type raise_kind =
+  | Raise_withtrace
+  | Raise_notrace
+
 type memory_chunk =
     Byte_unsigned
   | Byte_signed
@@ -120,11 +130,13 @@ type memory_chunk =
   | Double
   | Double_u
 
-type operation =
+and operation =
     Capply of machtype * Debuginfo.t
-  | Cextcall of string * machtype * bool * Debuginfo.t
+  | Cextcall of string * machtype * bool * Debuginfo.t * label option
+    (** If specified, the given label will be placed immediately after the
+        call (at the same place as any frame descriptor would reference). *)
   | Cload of memory_chunk
-  | Calloc
+  | Calloc of Debuginfo.t
   | Cstore of memory_chunk * Lambda.initialization_or_assignment
   | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
   | Cand | Cor | Cxor | Clsl | Clsr | Casr
@@ -135,7 +147,7 @@ type operation =
   | Caddf | Csubf | Cmulf | Cdivf
   | Cfloatofint | Cintoffloat
   | Ccmpf of comparison
-  | Craise of Lambda.raise_kind * Debuginfo.t
+  | Craise of raise_kind * Debuginfo.t
   | Ccheckbound of Debuginfo.t
 
 type expression =
@@ -145,7 +157,7 @@ type expression =
   | Cconst_symbol of string
   | Cconst_pointer of int
   | Cconst_natpointer of nativeint
-  | Cconst_blockheader of nativeint
+  | Cblockheader of nativeint * Debuginfo.t
   | Cvar of Ident.t
   | Clet of Ident.t * expression * expression
   | Cassign of Ident.t * expression
@@ -164,11 +176,11 @@ type fundecl =
     fun_args: (Ident.t * machtype) list;
     fun_body: expression;
     fun_fast: bool;
-    fun_dbg : Debuginfo.t; }
+    fun_dbg : Debuginfo.t;
+  }
 
 type data_item =
     Cdefine_symbol of string
-  | Cdefine_label of int
   | Cglobal_symbol of string
   | Cint8 of int
   | Cint16 of int
@@ -177,7 +189,6 @@ type data_item =
   | Csingle of float
   | Cdouble of float
   | Csymbol_address of string
-  | Clabel_address of int
   | Cstring of string
   | Cskip of int
   | Calign of int
@@ -185,3 +196,6 @@ type data_item =
 type phrase =
     Cfunction of fundecl
   | Cdata of data_item list
+
+let reset () =
+  label_counter := 99

diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
index 31c222cf63d8ca4da896acb22f866eba99b6b983..0b1a781e2aee156a418da5dd6dcdbe44f005419d 100644 (file)
--- a/asmcomp/cmm.mli
+++ b/asmcomp/cmm.mli
@@ -83,6 +83,13 @@ type comparison =
 val negate_comparison: comparison -> comparison
 val swap_comparison: comparison -> comparison
 
+type label = int
+val new_label: unit -> label
+
+type raise_kind =
+  | Raise_withtrace
+  | Raise_notrace
+
 type memory_chunk =
     Byte_unsigned
   | Byte_signed
@@ -96,11 +103,11 @@ type memory_chunk =
   | Double                             (* 64-bit-aligned 64-bit float *)
   | Double_u                           (* word-aligned 64-bit float *)
 
-type operation =
+and operation =
     Capply of machtype * Debuginfo.t
-  | Cextcall of string * machtype * bool * Debuginfo.t
+  | Cextcall of string * machtype * bool * Debuginfo.t * label option
   | Cload of memory_chunk
-  | Calloc
+  | Calloc of Debuginfo.t
   | Cstore of memory_chunk * Lambda.initialization_or_assignment
   | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi
   | Cand | Cor | Cxor | Clsl | Clsr | Casr
@@ -112,17 +119,17 @@ type operation =
   | Caddf | Csubf | Cmulf | Cdivf
   | Cfloatofint | Cintoffloat
   | Ccmpf of comparison
-  | Craise of Lambda.raise_kind * Debuginfo.t
+  | Craise of raise_kind * Debuginfo.t
   | Ccheckbound of Debuginfo.t
 
-type expression =
+and expression =
     Cconst_int of int
   | Cconst_natint of nativeint
   | Cconst_float of float
   | Cconst_symbol of string
   | Cconst_pointer of int
   | Cconst_natpointer of nativeint
-  | Cconst_blockheader of nativeint
+  | Cblockheader of nativeint * Debuginfo.t
   | Cvar of Ident.t
   | Clet of Ident.t * expression * expression
   | Cassign of Ident.t * expression
@@ -141,11 +148,11 @@ type fundecl =
     fun_args: (Ident.t * machtype) list;
     fun_body: expression;
     fun_fast: bool;
-    fun_dbg : Debuginfo.t; }
+    fun_dbg : Debuginfo.t;
+  }
 
 type data_item =
     Cdefine_symbol of string
-  | Cdefine_label of int
   | Cglobal_symbol of string
   | Cint8 of int
   | Cint16 of int
@@ -154,7 +161,6 @@ type data_item =
   | Csingle of float
   | Cdouble of float
   | Csymbol_address of string
-  | Clabel_address of int
   | Cstring of string
   | Cskip of int
   | Calign of int
@@ -162,3 +168,5 @@ type data_item =
 type phrase =
     Cfunction of fundecl
   | Cdata of data_item list
+
+val reset : unit -> unit

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 78a39ddb5fe329c65c8be179a2012fb92e1c94ec..fd21651f0cff86c776f0e336d1c99ccf820d3da7 100644 (file)
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -31,7 +31,7 @@ let bind name arg fn =
   match arg with
     Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
   | Cconst_pointer _ | Cconst_natpointer _
-  | Cconst_blockheader _ -> fn arg
+  | Cblockheader _ -> fn arg
   | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
 
 let bind_load name arg fn =
@@ -43,7 +43,7 @@ let bind_nonvar name arg fn =
   match arg with
     Cconst_int _ | Cconst_natint _ | Cconst_symbol _
   | Cconst_pointer _ | Cconst_natpointer _
-  | Cconst_blockheader _ -> fn arg
+  | Cblockheader _ -> fn arg
   | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
 
 let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8
@@ -72,13 +72,13 @@ let boxedint32_header = block_header Obj.custom_tag 2
 let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr)
 let boxedintnat_header = block_header Obj.custom_tag 2
 
-let alloc_float_header = Cconst_blockheader(float_header)
-let alloc_floatarray_header len = Cconst_blockheader(floatarray_header len)
-let alloc_closure_header sz = Cconst_blockheader(white_closure_header sz)
-let alloc_infix_header ofs = Cconst_blockheader(infix_header ofs)
-let alloc_boxedint32_header = Cconst_blockheader(boxedint32_header)
-let alloc_boxedint64_header = Cconst_blockheader(boxedint64_header)
-let alloc_boxedintnat_header = Cconst_blockheader(boxedintnat_header)
+let alloc_float_header dbg = Cblockheader(float_header, dbg)
+let alloc_floatarray_header len dbg = Cblockheader(floatarray_header len, dbg)
+let alloc_closure_header sz dbg = Cblockheader(white_closure_header sz, dbg)
+let alloc_infix_header ofs dbg = Cblockheader(infix_header ofs, dbg)
+let alloc_boxedint32_header dbg = Cblockheader(boxedint32_header, dbg)
+let alloc_boxedint64_header dbg = Cblockheader(boxedint64_header, dbg)
+let alloc_boxedintnat_header dbg = Cblockheader(boxedintnat_header, dbg)
 
 (* Integers *)
 
@@ -156,7 +156,7 @@ and mult_power2 c n = lsl_int c (Cconst_int (Misc.log2 n))
 
 let rec mul_int c1 c2 =
   match (c1, c2) with
-  | (c, Cconst_int 0) | (Cconst_int 0, c) ->
+  | (_, Cconst_int 0) | (Cconst_int 0, _) ->
       Cconst_int 0
   | (c, Cconst_int 1) | (Cconst_int 1, c) ->
       c
@@ -320,11 +320,19 @@ let validate d m p =
   ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0
 *)
 
-let rec div_int c1 c2 dbg =
+let raise_regular dbg exc =
+  Csequence(
+    Cop(Cstore (Thirtytwo_signed, Assignment),
+        [(Cconst_symbol "caml_backtrace_pos"); Cconst_int 0]),
+      Cop(Craise (Raise_withtrace, dbg),[exc]))
+
+let raise_symbol dbg symb =
+  raise_regular dbg (Cconst_symbol symb)
+
+let rec div_int c1 c2 is_safe dbg =
   match (c1, c2) with
     (c1, Cconst_int 0) ->
-      Csequence(c1, Cop(Craise (Raise_regular, dbg),
-                        [Cconst_symbol "caml_exn_Division_by_zero"]))
+      Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero")
   | (c1, Cconst_int 1) ->
       c1
   | (Cconst_int 0 as c1, c2) ->
@@ -346,7 +354,7 @@ let rec div_int c1 c2 dbg =
                      add_int c1 t);
                    Cconst_int l])
       else if n < 0 then
-        sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) dbg)
+        sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) is_safe dbg)
       else begin
         let (m, p) = divimm_parameters (Nativeint.of_int n) in
         (* Algorithm:
@@ -361,20 +369,18 @@ let rec div_int c1 c2 dbg =
           let t = if p > 0 then Cop(Casr, [t; Cconst_int p]) else t in
           add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1))))
       end
-  | (c1, c2) when !Clflags.fast ->
+  | (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe ->
       Cop(Cdivi, [c1; c2])
   | (c1, c2) ->
       bind "divisor" c2 (fun c2 ->
         Cifthenelse(c2,
                     Cop(Cdivi, [c1; c2]),
-                    Cop(Craise (Raise_regular, dbg),
-                        [Cconst_symbol "caml_exn_Division_by_zero"])))
+                    raise_symbol dbg "caml_exn_Division_by_zero"))
 
-let mod_int c1 c2 dbg =
+let mod_int c1 c2 is_safe dbg =
   match (c1, c2) with
     (c1, Cconst_int 0) ->
-      Csequence(c1, Cop(Craise (Raise_regular, dbg),
-                        [Cconst_symbol "caml_exn_Division_by_zero"]))
+      Csequence(c1, raise_symbol dbg "caml_exn_Division_by_zero")
   | (c1, Cconst_int (1 | (-1))) ->
       Csequence(c1, Cconst_int 0)
   | (Cconst_int 0, c2) ->
@@ -399,15 +405,15 @@ let mod_int c1 c2 dbg =
           sub_int c1 t)
       else
         bind "dividend" c1 (fun c1 ->
-          sub_int c1 (mul_int (div_int c1 c2 dbg) c2))
-  | (c1, c2) when !Clflags.fast ->
+          sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2))
+  | (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe ->
+      (* Flambda already generates that test *)
       Cop(Cmodi, [c1; c2])
   | (c1, c2) ->
       bind "divisor" c2 (fun c2 ->
         Cifthenelse(c2,
                     Cop(Cmodi, [c1; c2]),
-                    Cop(Craise (Raise_regular, dbg),
-                        [Cconst_symbol "caml_exn_Division_by_zero"])))
+                    raise_symbol dbg "caml_exn_Division_by_zero"))
 
 (* Division or modulo on boxed integers.  The overflow case min_int / -1
    can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)
@@ -417,21 +423,21 @@ let is_different_from x = function
   | Cconst_natint n -> n <> Nativeint.of_int x
   | _ -> false
 
-let safe_divmod_bi mkop mkm1 c1 c2 bi dbg =
+let safe_divmod_bi mkop is_safe mkm1 c1 c2 bi dbg =
   bind "dividend" c1 (fun c1 ->
   bind "divisor" c2 (fun c2 ->
-    let c = mkop c1 c2 dbg in
+    let c = mkop c1 c2 is_safe dbg in
     if Arch.division_crashes_on_overflow
     && (size_int = 4 || bi <> Pint32)
     && not (is_different_from (-1) c2)
     then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), c, mkm1 c1)
     else c))
 
-let safe_div_bi =
-  safe_divmod_bi div_int (fun c1 -> Cop(Csubi, [Cconst_int 0; c1]))
+let safe_div_bi is_safe =
+  safe_divmod_bi div_int is_safe (fun c1 -> Cop(Csubi, [Cconst_int 0; c1]))
 
-let safe_mod_bi =
-  safe_divmod_bi mod_int (fun c1 -> Cconst_int 0)
+let safe_mod_bi is_safe =
+  safe_divmod_bi mod_int is_safe (fun _ -> Cconst_int 0)
 
 (* Bool *)
 
@@ -446,10 +452,10 @@ let test_bool = function
 
 (* Float *)
 
-let box_float c = Cop(Calloc, [alloc_float_header; c])
+let box_float dbg c = Cop(Calloc dbg, [alloc_float_header dbg; c])
 
 let rec unbox_float = function
-    Cop(Calloc, [header; c]) -> c
+    Cop(Calloc _, [_header; c]) -> c
   | Clet(id, exp, body) -> Clet(id, exp, unbox_float body)
   | Cifthenelse(cond, e1, e2) ->
       Cifthenelse(cond, unbox_float e1, unbox_float e2)
@@ -461,8 +467,8 @@ let rec unbox_float = function
 
 (* Complex *)
 
-let box_complex c_re c_im =
-  Cop(Calloc, [alloc_floatarray_header 2; c_re; c_im])
+let box_complex dbg c_re c_im =
+  Cop(Calloc dbg, [alloc_floatarray_header 2 dbg; c_re; c_im])
 
 let complex_re c = Cop(Cload Double_u, [c])
 let complex_im c = Cop(Cload Double_u,
@@ -487,10 +493,10 @@ let rec remove_unit = function
       Ctrywith(remove_unit body, exn, remove_unit handler)
   | Clet(id, c1, c2) ->
       Clet(id, c1, remove_unit c2)
-  | Cop(Capply (mty, dbg), args) ->
+  | Cop(Capply (_mty, dbg), args) ->
       Cop(Capply (typ_void, dbg), args)
-  | Cop(Cextcall(proc, mty, alloc, dbg), args) ->
-      Cop(Cextcall(proc, typ_void, alloc, dbg), args)
+  | Cop(Cextcall(proc, _mty, alloc, dbg, label_after), args) ->
+      Cop(Cextcall(proc, typ_void, alloc, dbg, label_after), args)
   | Cexit (_,_) as c -> c
   | Ctuple [] as c -> c
   | c -> Csequence(c, Ctuple [])
@@ -510,7 +516,14 @@ let set_field ptr n newval init =
   Cop(Cstore (Word_val, init), [field_address ptr n; newval])
 
 let header ptr =
-  Cop(Cload Word_int, [Cop(Cadda, [ptr; Cconst_int(-size_int)])])
+  if Config.spacetime then
+    let non_profinfo_mask = (1 lsl (64 - Config.profinfo_width)) - 1 in
+    Cop(Cand, [Cop (Cload Word_int,
+        [Cop(Cadda, [ptr; Cconst_int(-size_int)])]);
+      Cconst_int non_profinfo_mask;
+    ])
+  else
+    Cop(Cload Word_int, [Cop(Cadda, [ptr; Cconst_int(-size_int)])])
 
 let tag_offset =
   if big_endian then -1 else -size_int
@@ -583,11 +596,11 @@ let int_array_ref arr ofs =
   Cop(Cload Word_int, [array_indexing log2_size_addr arr ofs])
 let unboxed_float_array_ref arr ofs =
   Cop(Cload Double_u, [array_indexing log2_size_float arr ofs])
-let float_array_ref arr ofs =
-  box_float(unboxed_float_array_ref arr ofs)
+let float_array_ref dbg arr ofs =
+  box_float dbg (unboxed_float_array_ref arr ofs)
 
 let addr_array_set arr ofs newval =
-  Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none),
+  Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none, None),
       [array_indexing log2_size_addr arr ofs; newval])
 let int_array_set arr ofs newval =
   Cop(Cstore (Word_int, Assignment),
@@ -618,7 +631,8 @@ let string_length exp =
 
 let lookup_tag obj tag =
   bind "tag" tag (fun tag ->
-    Cop(Cextcall("caml_get_public_method", typ_val, false, Debuginfo.none),
+    Cop(Cextcall("caml_get_public_method", typ_val, false, Debuginfo.none,
+          None),
         [obj; tag]))
 
 let lookup_label obj lab =
@@ -636,9 +650,9 @@ let call_cached_method obj tag cache pos args dbg =
 
 (* Allocation *)
 
-let make_alloc_generic set_fn tag wordsize args =
+let make_alloc_generic set_fn dbg tag wordsize args =
   if wordsize <= Config.max_young_wosize then
-    Cop(Calloc, Cconst_blockheader(block_header tag wordsize) :: args)
+    Cop(Calloc dbg, Cblockheader(block_header tag wordsize, dbg) :: args)
   else begin
     let id = Ident.create "alloc" in
     let rec fill_fields idx = function
@@ -646,15 +660,15 @@ let make_alloc_generic set_fn tag wordsize args =
     | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
                           fill_fields (idx + 2) el) in
     Clet(id,
-         Cop(Cextcall("caml_alloc", typ_val, true, Debuginfo.none),
+         Cop(Cextcall("caml_alloc", typ_val, true, Debuginfo.none, None),
                  [Cconst_int wordsize; Cconst_int tag]),
          fill_fields 1 args)
   end
 
-let make_alloc tag args =
-  make_alloc_generic addr_array_set tag (List.length args) args
-let make_float_alloc tag args =
-  make_alloc_generic float_array_set tag
+let make_alloc dbg tag args =
+  make_alloc_generic addr_array_set dbg tag (List.length args) args
+let make_float_alloc dbg tag args =
+  make_alloc_generic float_array_set dbg tag
                      (List.length args * size_float / size_addr) args
 
 (* Bounds checking *)
@@ -695,11 +709,11 @@ let rec expr_size env = function
       begin try Ident.find_same id env with Not_found -> RHS_nonrec end
   | Uclosure(fundecls, clos_vars) ->
       RHS_block (fundecls_size fundecls + List.length clos_vars)
-  | Ulet(id, exp, body) ->
+  | Ulet(_str, _kind, id, exp, body) ->
       expr_size (Ident.add id (expr_size env exp) env) body
-  | Uletrec(bindings, body) ->
+  | Uletrec(_bindings, body) ->
       expr_size env body
-  | Uprim(Pmakeblock(tag, mut), args, _) ->
+  | Uprim(Pmakeblock _, args, _) ->
       RHS_block (List.length args)
   | Uprim(Pmakearray((Paddrarray | Pintarray), _), args, _) ->
       RHS_block (List.length args)
@@ -707,6 +721,8 @@ let rec expr_size env = function
       RHS_floatblock (List.length args)
   | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
       RHS_block sz
+  | Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
+      assert false
   | Uprim (Pduprecord (Record_extension, sz), _, _) ->
       RHS_block (sz + 1)
   | Uprim (Pduprecord (Record_float, sz), _, _) ->
@@ -715,7 +731,7 @@ let rec expr_size env = function
         when prim_name = "caml_check_value_is_closure" ->
       (* Used for "-clambda-checks". *)
       expr_size env closure
-  | Usequence(exp, exp') ->
+  | Usequence(_exp, exp') ->
       expr_size env exp'
   | _ -> RHS_nonrec
 
@@ -783,7 +799,7 @@ let alloc_header_boxed_int bi =
   | Pint32 -> alloc_boxedint32_header
   | Pint64 -> alloc_boxedint64_header
 
-let box_int bi arg =
+let box_int dbg bi arg =
   match arg with
     Cconst_int n ->
       transl_structured_constant (box_int_constant bi (Nativeint.of_int n))
@@ -794,7 +810,7 @@ let box_int bi arg =
         if bi = Pint32 && size_int = 8 && big_endian
         then Cop(Clsl, [arg; Cconst_int 32])
         else arg in
-      Cop(Calloc, [alloc_header_boxed_int bi;
+      Cop(Calloc dbg, [alloc_header_boxed_int bi dbg;
                    Cconst_symbol(operations_boxed_int bi);
                    arg'])
 
@@ -807,15 +823,15 @@ let split_int64_for_32bit_target arg =
 
 let rec unbox_int bi arg =
   match arg with
-    Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])])
+    Cop(Calloc _, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32])])
     when bi = Pint32 && size_int = 8 && big_endian ->
       (* Force sign-extension of low 32 bits *)
       Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
-  | Cop(Calloc, [hdr; ops; contents])
+  | Cop(Calloc _, [_hdr; _ops; contents])
     when bi = Pint32 && size_int = 8 && not big_endian ->
       (* Force sign-extension of low 32 bits *)
       Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
-  | Cop(Calloc, [hdr; ops; contents]) ->
+  | Cop(Calloc _, [_hdr; _ops; contents]) ->
       contents
   | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body)
   | Cifthenelse(cond, e1, e2) ->
@@ -839,13 +855,27 @@ let make_unsigned_int bi arg =
 (* Boxed numbers *)
 
 type boxed_number =
-  | Boxed_float
-  | Boxed_integer of boxed_integer
+  | Boxed_float of Debuginfo.t
+  | Boxed_integer of boxed_integer * Debuginfo.t
+
+let equal_unboxed_integer ui1 ui2 =
+  match ui1, ui2 with
+  | Pnativeint, Pnativeint -> true
+  | Pint32, Pint32 -> true
+  | Pint64, Pint64 -> true
+  | _, _ -> false
+
+let equal_boxed_number bn1 bn2 =
+  match bn1, bn2 with
+  | Boxed_float _, Boxed_float _ -> true
+  | Boxed_integer(ui1, _), Boxed_integer(ui2, _) ->
+    equal_unboxed_integer ui1 ui2
+  | _, _ -> false
 
 let box_number bn arg =
   match bn with
-  | Boxed_float -> box_float arg
-  | Boxed_integer bi -> box_int bi arg
+  | Boxed_float dbg -> box_float dbg arg
+  | Boxed_integer (bi, dbg) -> box_int dbg bi arg
 
 type env = {
   unboxed_ids : (Ident.t * boxed_number) Ident.tbl;
@@ -954,7 +984,7 @@ let bigarray_get unsafe elt_kind layout b args dbg =
         let sz = bigarray_elt_size elt_kind / 2 in
         bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg)
           (fun addr ->
-          box_complex
+          box_complex dbg
             (Cop(Cload kind, [addr]))
             (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
     | _ ->
@@ -1162,8 +1192,8 @@ let simplif_primitive_32bits = function
   | Paddbint Pint64 -> Pccall (default_prim "caml_int64_add")
   | Psubbint Pint64 -> Pccall (default_prim "caml_int64_sub")
   | Pmulbint Pint64 -> Pccall (default_prim "caml_int64_mul")
-  | Pdivbint Pint64 -> Pccall (default_prim "caml_int64_div")
-  | Pmodbint Pint64 -> Pccall (default_prim "caml_int64_mod")
+  | Pdivbint {size=Pint64} -> Pccall (default_prim "caml_int64_div")
+  | Pmodbint {size=Pint64} -> Pccall (default_prim "caml_int64_mod")
   | Pandbint Pint64 -> Pccall (default_prim "caml_int64_and")
   | Porbint Pint64 ->  Pccall (default_prim "caml_int64_or")
   | Pxorbint Pint64 -> Pccall (default_prim "caml_int64_xor")
@@ -1176,9 +1206,9 @@ let simplif_primitive_32bits = function
   | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan")
   | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal")
   | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal")
-  | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) ->
+  | Pbigarrayref(_unsafe, n, Pbigarray_int64, _layout) ->
       Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
-  | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) ->
+  | Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) ->
       Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
   | Pstring_load_64(_) -> Pccall (default_prim "caml_string_get64")
   | Pstring_set_64(_) -> Pccall (default_prim "caml_string_set64")
@@ -1191,13 +1221,13 @@ let simplif_primitive p =
   match p with
   | Pduprecord _ ->
       Pccall (default_prim "caml_obj_dup")
-  | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) ->
+  | Pbigarrayref(_unsafe, n, Pbigarray_unknown, _layout) ->
       Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
-  | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) ->
+  | Pbigarrayset(_unsafe, n, Pbigarray_unknown, _layout) ->
       Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
-  | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) ->
+  | Pbigarrayref(_unsafe, n, _kind, Pbigarray_unknown_layout) ->
       Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
-  | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) ->
+  | Pbigarrayset(_unsafe, n, _kind, Pbigarray_unknown_layout) ->
       Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
   | p ->
       if size_int = 8 then p else simplif_primitive_32bits p
@@ -1317,83 +1347,97 @@ let transl_int_switch arg low high cases default = match cases with
 
 type unboxed_number_kind =
     No_unboxing
-  | Boxed of boxed_number
+  | Boxed of boxed_number * bool (* true: boxed form available at no cost *)
   | No_result (* expression never returns a result *)
 
-let unboxed_number_kind_of_unbox = function
+let unboxed_number_kind_of_unbox dbg = function
   | Same_as_ocaml_repr -> No_unboxing
-  | Unboxed_float -> Boxed Boxed_float
-  | Unboxed_integer bi -> Boxed (Boxed_integer bi)
+  | Unboxed_float -> Boxed (Boxed_float dbg, false)
+  | Unboxed_integer bi -> Boxed (Boxed_integer (bi, dbg), false)
   | Untagged_int -> No_unboxing
 
-let rec is_unboxed_number env e =
+let rec is_unboxed_number ~strict env e =
   (* Given unboxed_number_kind from two branches of the code, returns the
-     resulting unboxed_number_kind *)
+     resulting unboxed_number_kind.
+
+     If [strict=false], one knows that the type of the expression
+     is an unboxable number, and we decide to return an unboxed value
+     if this indeed eliminates at least one allocation.
+
+     If [strict=true], we need to ensure that all possible branches
+     return an unboxable number (of the same kind).  This could not
+     be the case in presence of GADTs.
+ *)
   let join k1 e =
-    match k1, is_unboxed_number env e with
-    | Boxed b1, Boxed b2 when b1 = b2 -> Boxed b1
+    match k1, is_unboxed_number ~strict env e with
+    | Boxed (b1, c1), Boxed (b2, c2) when equal_boxed_number b1 b2 ->
+        Boxed (b1, c1 && c2)
     | No_result, k | k, No_result ->
         k (* if a branch never returns, it is safe to unbox it *)
+    | No_unboxing, k | k, No_unboxing when not strict ->
+        k
     | _, _ -> No_unboxing
   in
   match e with
   | Uvar id ->
       begin match is_unboxed_id id env with
       | None -> No_unboxing
-      | Some (_, bn) -> Boxed bn
+      | Some (_, bn) -> Boxed (bn, false)
       end
 
   | Uconst(Uconst_ref(_, Some (Uconst_float _))) ->
-      Boxed Boxed_float
+      Boxed (Boxed_float Debuginfo.none, true)
   | Uconst(Uconst_ref(_, Some (Uconst_int32 _))) ->
-      Boxed (Boxed_integer Pint32)
+      Boxed (Boxed_integer (Pint32, Debuginfo.none), true)
   | Uconst(Uconst_ref(_, Some (Uconst_int64 _))) ->
-      Boxed (Boxed_integer Pint64)
+      Boxed (Boxed_integer (Pint64, Debuginfo.none), true)
   | Uconst(Uconst_ref(_, Some (Uconst_nativeint _))) ->
-      Boxed (Boxed_integer Pnativeint)
-  | Uprim(p, _, _) ->
+      Boxed (Boxed_integer (Pnativeint, Debuginfo.none), true)
+  | Uprim(p, _, dbg) ->
       begin match simplif_primitive p with
-        | Pccall p -> unboxed_number_kind_of_unbox p.prim_native_repr_res
-        | Pfloatfield _ -> Boxed Boxed_float
-        | Pfloatofint -> Boxed Boxed_float
-        | Pnegfloat -> Boxed Boxed_float
-        | Pabsfloat -> Boxed Boxed_float
-        | Paddfloat -> Boxed Boxed_float
-        | Psubfloat -> Boxed Boxed_float
-        | Pmulfloat -> Boxed Boxed_float
-        | Pdivfloat -> Boxed Boxed_float
-        | Parrayrefu Pfloatarray -> Boxed Boxed_float
-        | Parrayrefs Pfloatarray -> Boxed Boxed_float
-        | Pbintofint bi -> Boxed (Boxed_integer bi)
-        | Pcvtbint(src, dst) -> Boxed (Boxed_integer dst)
-        | Pnegbint bi -> Boxed (Boxed_integer bi)
-        | Paddbint bi -> Boxed (Boxed_integer bi)
-        | Psubbint bi -> Boxed (Boxed_integer bi)
-        | Pmulbint bi -> Boxed (Boxed_integer bi)
-        | Pdivbint bi -> Boxed (Boxed_integer bi)
-        | Pmodbint bi -> Boxed (Boxed_integer bi)
-        | Pandbint bi -> Boxed (Boxed_integer bi)
-        | Porbint bi -> Boxed (Boxed_integer bi)
-        | Pxorbint bi -> Boxed (Boxed_integer bi)
-        | Plslbint bi -> Boxed (Boxed_integer bi)
-        | Plsrbint bi -> Boxed (Boxed_integer bi)
-        | Pasrbint bi -> Boxed (Boxed_integer bi)
+        | Pccall p -> unboxed_number_kind_of_unbox dbg p.prim_native_repr_res
+        | Pfloatfield _
+        | Pfloatofint
+        | Pnegfloat
+        | Pabsfloat
+        | Paddfloat
+        | Psubfloat
+        | Pmulfloat
+        | Pdivfloat
+        | Parrayrefu Pfloatarray
+        | Parrayrefs Pfloatarray -> Boxed (Boxed_float dbg, false)
+        | Pbintofint bi
+        | Pcvtbint(_, bi)
+        | Pnegbint bi
+        | Paddbint bi
+        | Psubbint bi
+        | Pmulbint bi
+        | Pdivbint {size=bi}
+        | Pmodbint {size=bi}
+        | Pandbint bi
+        | Porbint bi
+        | Pxorbint bi
+        | Plslbint bi
+        | Plsrbint bi
+        | Pasrbint bi
+        | Pbbswap bi -> Boxed (Boxed_integer (bi, dbg), false)
         | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) ->
-            Boxed Boxed_float
-        | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed (Boxed_integer Pint32)
-        | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed (Boxed_integer Pint64)
+            Boxed (Boxed_float dbg, false)
+        | Pbigarrayref(_, _, Pbigarray_int32, _) ->
+            Boxed (Boxed_integer (Pint32, dbg), false)
+        | Pbigarrayref(_, _, Pbigarray_int64, _) ->
+            Boxed (Boxed_integer (Pint64, dbg), false)
         | Pbigarrayref(_, _, Pbigarray_native_int,_) ->
-            Boxed (Boxed_integer Pnativeint)
-        | Pstring_load_32(_) -> Boxed (Boxed_integer Pint32)
-        | Pstring_load_64(_) -> Boxed (Boxed_integer Pint64)
-        | Pbigstring_load_32(_) -> Boxed (Boxed_integer Pint32)
-        | Pbigstring_load_64(_) -> Boxed (Boxed_integer Pint64)
-        | Pbbswap bi -> Boxed (Boxed_integer bi)
+            Boxed (Boxed_integer (Pnativeint, dbg), false)
+        | Pstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false)
+        | Pstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false)
+        | Pbigstring_load_32(_) -> Boxed (Boxed_integer (Pint32, dbg), false)
+        | Pbigstring_load_64(_) -> Boxed (Boxed_integer (Pint64, dbg), false)
         | Praise _ -> No_result
         | _ -> No_unboxing
       end
-  | Ulet (_, _, e) | Uletrec (_, e) | Usequence (_, e) ->
-      is_unboxed_number env e
+  | Ulet (_, _, _, _, e) | Uletrec (_, e) | Usequence (_, e) ->
+      is_unboxed_number ~strict env e
   | Uswitch (_, switch) ->
       let k = Array.fold_left join No_result switch.us_actions_consts in
       Array.fold_left join k switch.us_actions_blocks
@@ -1405,7 +1449,7 @@ let rec is_unboxed_number env e =
       end
   | Ustaticfail _ -> No_result
   | Uifthenelse (_, e1, e2) | Ucatch (_, _, e1, e2) | Utrywith (e1, _, e2) ->
-      join (is_unboxed_number env e1) e2
+      join (is_unboxed_number ~strict env e1) e2
   | _ -> No_unboxing
 
 (* Translate an expression *)
@@ -1446,8 +1490,8 @@ let rec transl env e =
             Queue.add f functions;
             let header =
               if pos = 0
-              then alloc_closure_header block_size
-              else alloc_infix_header pos in
+              then alloc_closure_header block_size f.dbg
+              else alloc_infix_header pos f.dbg in
             if f.arity = 1 || f.arity = 0 then
               header ::
               Cconst_symbol f.label ::
@@ -1459,7 +1503,7 @@ let rec transl env e =
               int_const f.arity ::
               Cconst_symbol f.label ::
               transl_fundecls (pos + 4) rem in
-      Cop(Calloc, transl_fundecls 0 fundecls)
+      Cop(Calloc Debuginfo.none, transl_fundecls 0 fundecls)
   | Uoffset(arg, offset) ->
       (* produces a valid Caml value, pointing just after an infix header *)
       let ptr = transl env arg in
@@ -1496,8 +1540,8 @@ let rec transl env e =
               (List.map (transl env) args) dbg
         | _ ->
             bind "met" (lookup_tag obj (transl env met)) (call_met obj args))
-  | Ulet(id, exp, body) ->
-      transl_let env id exp body
+  | Ulet(str, kind, id, exp, body) ->
+      transl_let env str kind id exp body
   | Uletrec(bindings, body) ->
       transl_letrec env bindings (transl env body)
 
@@ -1506,10 +1550,10 @@ let rec transl env e =
       begin match (simplif_primitive prim, args) with
         (Pgetglobal id, []) ->
           Cconst_symbol (Ident.name id)
-      | (Pmakeblock(tag, mut), []) ->
+      | (Pmakeblock _, []) ->
           assert false
-      | (Pmakeblock(tag, mut), args) ->
-          make_alloc tag (List.map (transl env) args)
+      | (Pmakeblock(tag, _mut, _kind), args) ->
+          make_alloc dbg tag (List.map (transl env) args)
       | (Pccall prim, args) ->
           transl_ccall env prim args dbg
       | (Pduparray (kind, _), [Uprim (Pmakearray (kind', _), args, _dbg)]) ->
@@ -1524,29 +1568,29 @@ let rec transl env e =
              state of [Translcore], we will in fact only get here with
              [Pfloatarray]s. *)
           assert (kind = kind');
-          transl_make_array env kind args
+          transl_make_array dbg env kind args
       | (Pduparray _, [arg]) ->
           let prim_obj_dup =
             Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
           in
           transl_ccall env prim_obj_dup [arg] dbg
-      | (Pmakearray (kind, _), []) ->
+      | (Pmakearray _, []) ->
           transl_structured_constant (Uconst_block(0, []))
-      | (Pmakearray (kind, _), args) -> transl_make_array env kind args
-      | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
+      | (Pmakearray (kind, _), args) -> transl_make_array dbg env kind args
+      | (Pbigarrayref(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
           let elt =
             bigarray_get unsafe elt_kind layout
               (transl env arg1) (List.map (transl env) argl) dbg in
           begin match elt_kind with
-            Pbigarray_float32 | Pbigarray_float64 -> box_float elt
+            Pbigarray_float32 | Pbigarray_float64 -> box_float dbg elt
           | Pbigarray_complex32 | Pbigarray_complex64 -> elt
-          | Pbigarray_int32 -> box_int Pint32 elt
-          | Pbigarray_int64 -> box_int Pint64 elt
-          | Pbigarray_native_int -> box_int Pnativeint elt
+          | Pbigarray_int32 -> box_int dbg Pint32 elt
+          | Pbigarray_int64 -> box_int dbg Pint64 elt
+          | Pbigarray_native_int -> box_int dbg Pnativeint elt
           | Pbigarray_caml_int -> force_tag_int elt
           | _ -> tag_int elt
           end
-      | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
+      | (Pbigarrayset(unsafe, _num_dims, elt_kind, layout), arg1 :: argl) ->
           let (argidx, argnewval) = split_last argl in
           return_unit(bigarray_set unsafe elt_kind layout
             (transl env arg1)
@@ -1683,15 +1727,15 @@ let rec transl env e =
   | Uunreachable ->
       Cop(Cload Word_int, [Cconst_int 0])
 
-and transl_make_array env kind args =
+and transl_make_array dbg env kind args =
   match kind with
   | Pgenarray ->
-      Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none),
-          [make_alloc 0 (List.map (transl env) args)])
+      Cop(Cextcall("caml_make_array", typ_val, true, Debuginfo.none, None),
+          [make_alloc dbg 0 (List.map (transl env) args)])
   | Paddrarray | Pintarray ->
-      make_alloc 0 (List.map (transl env) args)
+      make_alloc dbg 0 (List.map (transl env) args)
   | Pfloatarray ->
-      make_float_alloc Obj.double_array_tag
+      make_float_alloc dbg Obj.double_array_tag
                       (List.map (transl_unbox_float env) args)
 
 and transl_ccall env prim args dbg =
@@ -1715,20 +1759,21 @@ and transl_ccall env prim args dbg =
   let typ_res, wrap_result =
     match prim.prim_native_repr_res with
     | Same_as_ocaml_repr -> (typ_val, fun x -> x)
-    | Unboxed_float -> (typ_float, box_float)
-    | Unboxed_integer Pint64 when size_int = 4 -> ([|Int; Int|], box_int Pint64)
-    | Unboxed_integer bi -> (typ_int, box_int bi)
+    | Unboxed_float -> (typ_float, box_float dbg)
+    | Unboxed_integer Pint64 when size_int = 4 ->
+        ([|Int; Int|], box_int dbg Pint64)
+    | Unboxed_integer bi -> (typ_int, box_int dbg bi)
     | Untagged_int -> (typ_int, tag_int)
   in
   let args = transl_args prim.prim_native_repr_args args in
   wrap_result
     (Cop(Cextcall(Primitive.native_name prim,
-                  typ_res, prim.prim_alloc, dbg), args))
+                  typ_res, prim.prim_alloc, dbg, None), args))
 
 and transl_prim_1 env p arg dbg =
   match p with
   (* Generic operations *)
-    Pidentity | Popaque ->
+    Pidentity | Pbytes_to_string | Pbytes_of_string | Popaque ->
       transl env arg
   | Pignore ->
       return_unit(remove_unit (transl env arg))
@@ -1737,7 +1782,7 @@ and transl_prim_1 env p arg dbg =
       get_field (transl env arg) n
   | Pfloatfield n ->
       let ptr = transl env arg in
-      box_float(
+      box_float dbg (
         Cop(Cload Double_u,
             [if n = 0 then ptr
                        else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
@@ -1745,8 +1790,14 @@ and transl_prim_1 env p arg dbg =
      Cop(Caddi, [transl env arg; Cconst_int (-1)])
      (* always a pointer outside the heap *)
   (* Exceptions *)
-  | Praise k ->
-      Cop(Craise (k, dbg), [transl env arg])
+  | Praise _ when not (!Clflags.debug) ->
+      Cop(Craise (Cmm.Raise_notrace, dbg), [transl env arg])
+  | Praise Lambda.Raise_notrace ->
+      Cop(Craise (Cmm.Raise_notrace, dbg), [transl env arg])
+  | Praise Lambda.Raise_reraise ->
+      Cop(Craise (Cmm.Raise_withtrace, dbg), [transl env arg])
+  | Praise Lambda.Raise_regular ->
+      raise_regular dbg (transl env arg)
   (* Integer operations *)
   | Pnegint ->
       Cop(Csubi, [Cconst_int 2; transl env arg])
@@ -1762,6 +1813,8 @@ and transl_prim_1 env p arg dbg =
         | Ostype_unix -> const_of_bool (Sys.os_type = "Unix")
         | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32")
         | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin")
+        | Backend_type ->
+            tag_int (Cconst_int 0) (* tag 0 is the same as Native here *)
       end
   | Poffsetint n ->
       if no_overflow_lsl n 1 then
@@ -1776,15 +1829,15 @@ and transl_prim_1 env p arg dbg =
               [arg; add_const (Cop(Cload Word_int, [arg])) (n lsl 1)])))
   (* Floating-point operations *)
   | Pfloatofint ->
-      box_float(Cop(Cfloatofint, [untag_int(transl env arg)]))
+      box_float dbg (Cop(Cfloatofint, [untag_int(transl env arg)]))
   | Pintoffloat ->
      tag_int(Cop(Cintoffloat, [transl_unbox_float env arg]))
   | Pnegfloat ->
-      box_float(Cop(Cnegf, [transl_unbox_float env arg]))
+      box_float dbg (Cop(Cnegf, [transl_unbox_float env arg]))
   | Pabsfloat ->
-      box_float(Cop(Cabsf, [transl_unbox_float env arg]))
+      box_float dbg (Cop(Cabsf, [transl_unbox_float env arg]))
   (* String operations *)
-  | Pstringlength ->
+  | Pstringlength | Pbyteslength ->
       tag_int(string_length (transl env arg))
   (* Array operations *)
   | Parraylength kind ->
@@ -1812,24 +1865,24 @@ and transl_prim_1 env p arg dbg =
       tag_int(Cop(Cand, [transl env arg; Cconst_int 1]))
   (* Boxed integers *)
   | Pbintofint bi ->
-      box_int bi (untag_int (transl env arg))
+      box_int dbg bi (untag_int (transl env arg))
   | Pintofbint bi ->
       force_tag_int (transl_unbox_int env bi arg)
   | Pcvtbint(bi1, bi2) ->
-      box_int bi2 (transl_unbox_int env bi1 arg)
+      box_int dbg bi2 (transl_unbox_int env bi1 arg)
   | Pnegbint bi ->
-      box_int bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int env bi arg]))
+      box_int dbg bi (Cop(Csubi, [Cconst_int 0; transl_unbox_int env bi arg]))
   | Pbbswap bi ->
       let prim = match bi with
         | Pnativeint -> "nativeint"
         | Pint32 -> "int32"
         | Pint64 -> "int64" in
-      box_int bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
-                               typ_int, false, Debuginfo.none),
+      box_int dbg bi (Cop(Cextcall(Printf.sprintf "caml_%s_direct_bswap" prim,
+                               typ_int, false, Debuginfo.none, None),
                       [transl_unbox_int env bi arg]))
   | Pbswap16 ->
       tag_int (Cop(Cextcall("caml_bswap16_direct", typ_int, false,
-                            Debuginfo.none),
+                            Debuginfo.none, None),
                    [untag_int (transl env arg)]))
   | prim ->
       fatal_errorf "Cmmgen.transl_prim_1: %a" Printlambda.primitive prim
@@ -1840,7 +1893,8 @@ and transl_prim_2 env p arg1 arg2 dbg =
     Psetfield(n, ptr, init) ->
       begin match init, ptr with
       | Assignment, Pointer ->
-        return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
+        return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none,
+                          None),
                         [field_address (transl env arg1) n; transl env arg2]))
       | Assignment, Immediate
       | Initialization, (Immediate | Pointer) ->
@@ -1882,12 +1936,12 @@ and transl_prim_2 env p arg1 arg2 dbg =
              incr_int (mul_int (untag_int c1) (decr_int c2))
          | c1, c2 -> incr_int (mul_int (decr_int c1) (untag_int c2))
      end
-  | Pdivint ->
+  | Pdivint is_safe ->
       tag_int(div_int (untag_int(transl env arg1))
-        (untag_int(transl env arg2)) dbg)
-  | Pmodint ->
+        (untag_int(transl env arg2)) is_safe dbg)
+  | Pmodint is_safe ->
       tag_int(mod_int (untag_int(transl env arg1))
-        (untag_int(transl env arg2)) dbg)
+        (untag_int(transl env arg2)) is_safe dbg)
   | Pandint ->
       Cop(Cand, [transl env arg1; transl env arg2])
   | Porint ->
@@ -1911,26 +1965,26 @@ and transl_prim_2 env p arg1 arg2 dbg =
       transl_isout (transl env arg1) (transl env arg2)
   (* Float operations *)
   | Paddfloat ->
-      box_float(Cop(Caddf,
+      box_float dbg (Cop(Caddf,
                     [transl_unbox_float env arg1; transl_unbox_float env arg2]))
   | Psubfloat ->
-      box_float(Cop(Csubf,
+      box_float dbg (Cop(Csubf,
                     [transl_unbox_float env arg1; transl_unbox_float env arg2]))
   | Pmulfloat ->
-      box_float(Cop(Cmulf,
+      box_float dbg (Cop(Cmulf,
                     [transl_unbox_float env arg1; transl_unbox_float env arg2]))
   | Pdivfloat ->
-      box_float(Cop(Cdivf,
+      box_float dbg (Cop(Cdivf,
                     [transl_unbox_float env arg1; transl_unbox_float env arg2]))
   | Pfloatcomp cmp ->
       tag_int(Cop(Ccmpf(transl_comparison cmp),
                   [transl_unbox_float env arg1; transl_unbox_float env arg2]))
 
   (* String operations *)
-  | Pstringrefu ->
+  | Pstringrefu | Pbytesrefu ->
       tag_int(Cop(Cload Byte_unsigned,
                   [add_int (transl env arg1) (untag_int(transl env arg2))]))
-  | Pstringrefs ->
+  | Pstringrefs | Pbytesrefs ->
       tag_int
         (bind "str" (transl env arg1) (fun str ->
           bind "index" (untag_int (transl env arg2)) (fun idx ->
@@ -1957,14 +2011,14 @@ and transl_prim_2 env p arg1 arg2 dbg =
                       (unaligned_load_16 ba_data idx)))))
 
   | Pstring_load_32(unsafe) ->
-     box_int Pint32
+     box_int dbg Pint32
        (bind "str" (transl env arg1) (fun str ->
         bind "index" (untag_int (transl env arg2)) (fun idx ->
           check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 3))
                       idx (unaligned_load_32 str idx))))
 
   | Pbigstring_load_32(unsafe) ->
-     box_int Pint32
+     box_int dbg Pint32
        (bind "ba" (transl env arg1) (fun ba ->
         bind "index" (untag_int (transl env arg2)) (fun idx ->
         bind "ba_data" (Cop(Cload Word_int, [field_address ba 1]))
@@ -1975,14 +2029,14 @@ and transl_prim_2 env p arg1 arg2 dbg =
                       (unaligned_load_32 ba_data idx)))))
 
   | Pstring_load_64(unsafe) ->
-     box_int Pint64
+     box_int dbg Pint64
        (bind "str" (transl env arg1) (fun str ->
         bind "index" (untag_int (transl env arg2)) (fun idx ->
           check_bound unsafe dbg (sub_int (string_length str) (Cconst_int 7))
                       idx (unaligned_load_64 str idx))))
 
   | Pbigstring_load_64(unsafe) ->
-     box_int Pint64
+     box_int dbg Pint64
        (bind "ba" (transl env arg1) (fun ba ->
         bind "index" (untag_int (transl env arg2)) (fun idx ->
         bind "ba_data" (Cop(Cload Word_int, [field_address ba 1]))
@@ -2000,13 +2054,13 @@ and transl_prim_2 env p arg1 arg2 dbg =
             bind "index" (transl env arg2) (fun idx ->
               Cifthenelse(is_addr_array_ptr arr,
                           addr_array_ref arr idx,
-                          float_array_ref arr idx)))
+                          float_array_ref dbg arr idx)))
       | Paddrarray ->
           addr_array_ref (transl env arg1) (transl env arg2)
       | Pintarray ->
           int_array_ref (transl env arg1) (transl env arg2)
       | Pfloatarray ->
-          float_array_ref (transl env arg1) (transl env arg2)
+          float_array_ref dbg (transl env arg1) (transl env arg2)
       end
   | Parrayrefs kind ->
       begin match kind with
@@ -2018,13 +2072,13 @@ and transl_prim_2 env p arg1 arg2 dbg =
               Csequence(make_checkbound dbg [addr_array_length hdr; idx],
                         Cifthenelse(is_addr_array_hdr hdr,
                                     addr_array_ref arr idx,
-                                    float_array_ref arr idx))
+                                    float_array_ref dbg arr idx))
             else
               Cifthenelse(is_addr_array_hdr hdr,
                 Csequence(make_checkbound dbg [addr_array_length hdr; idx],
                           addr_array_ref arr idx),
                 Csequence(make_checkbound dbg [float_array_length hdr; idx],
-                          float_array_ref arr idx)))))
+                          float_array_ref dbg arr idx)))))
       | Paddrarray ->
           bind "index" (transl env arg2) (fun idx ->
           bind "arr" (transl env arg1) (fun arr ->
@@ -2036,7 +2090,7 @@ and transl_prim_2 env p arg1 arg2 dbg =
             Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
                       int_array_ref arr idx)))
       | Pfloatarray ->
-          box_float(
+          box_float dbg (
             bind "index" (transl env arg2) (fun idx ->
             bind "arr" (transl env arg1) (fun arr ->
               Csequence(make_checkbound dbg
@@ -2056,49 +2110,49 @@ and transl_prim_2 env p arg1 arg2 dbg =
 
   (* Boxed integers *)
   | Paddbint bi ->
-      box_int bi (Cop(Caddi,
+      box_int dbg bi (Cop(Caddi,
                       [transl_unbox_int env bi arg1;
                        transl_unbox_int env bi arg2]))
   | Psubbint bi ->
-      box_int bi (Cop(Csubi,
+      box_int dbg bi (Cop(Csubi,
                       [transl_unbox_int env bi arg1;
                        transl_unbox_int env bi arg2]))
   | Pmulbint bi ->
-      box_int bi (Cop(Cmuli,
+      box_int dbg bi (Cop(Cmuli,
                       [transl_unbox_int env bi arg1;
                        transl_unbox_int env bi arg2]))
-  | Pdivbint bi ->
-      box_int bi (safe_div_bi
+  | Pdivbint { size = bi; is_safe } ->
+      box_int dbg bi (safe_div_bi is_safe
                       (transl_unbox_int env bi arg1)
                       (transl_unbox_int env bi arg2)
                       bi dbg)
-  | Pmodbint bi ->
-      box_int bi (safe_mod_bi
+  | Pmodbint { size = bi; is_safe } ->
+      box_int dbg bi (safe_mod_bi is_safe
                       (transl_unbox_int env bi arg1)
                       (transl_unbox_int env bi arg2)
                       bi dbg)
   | Pandbint bi ->
-      box_int bi (Cop(Cand,
+      box_int dbg bi (Cop(Cand,
                      [transl_unbox_int env bi arg1;
                       transl_unbox_int env bi arg2]))
   | Porbint bi ->
-      box_int bi (Cop(Cor,
+      box_int dbg bi (Cop(Cor,
                      [transl_unbox_int env bi arg1;
                       transl_unbox_int env bi arg2]))
   | Pxorbint bi ->
-      box_int bi (Cop(Cxor,
+      box_int dbg bi (Cop(Cxor,
                      [transl_unbox_int env bi arg1;
                       transl_unbox_int env bi arg2]))
   | Plslbint bi ->
-      box_int bi (Cop(Clsl,
+      box_int dbg bi (Cop(Clsl,
                      [transl_unbox_int env bi arg1;
                       untag_int(transl env arg2)]))
   | Plsrbint bi ->
-      box_int bi (Cop(Clsr,
+      box_int dbg bi (Cop(Clsr,
                      [make_unsigned_int bi (transl_unbox_int env bi arg1);
                       untag_int(transl env arg2)]))
   | Pasrbint bi ->
-      box_int bi (Cop(Casr,
+      box_int dbg bi (Cop(Casr,
                      [transl_unbox_int env bi arg1;
                       untag_int(transl env arg2)]))
   | Pbintcomp(bi, cmp) ->
@@ -2111,11 +2165,11 @@ and transl_prim_2 env p arg1 arg2 dbg =
 and transl_prim_3 env p arg1 arg2 arg3 dbg =
   match p with
   (* String operations *)
-    Pstringsetu ->
+  | Pbytessetu ->
       return_unit(Cop(Cstore (Byte_unsigned, Assignment),
                       [add_int (transl env arg1) (untag_int(transl env arg2));
                         untag_int(transl env arg3)]))
-  | Pstringsets ->
+  | Pbytessets ->
       return_unit
         (bind "str" (transl env arg1) (fun str ->
           bind "index" (untag_int (transl env arg2)) (fun idx ->
@@ -2269,18 +2323,44 @@ and transl_unbox_int env bi = function
 
 and transl_unbox_number env bn arg =
   match bn with
-  | Boxed_float -> transl_unbox_float env arg
-  | Boxed_integer bi -> transl_unbox_int env bi arg
-
-and transl_let env id exp body =
-  match is_unboxed_number env exp with
-  |  No_unboxing ->
+  | Boxed_float _ -> transl_unbox_float env arg
+  | Boxed_integer (bi, _) -> transl_unbox_int env bi arg
+
+and transl_let env str kind id exp body =
+  let unboxing =
+    (* If [id] is a mutable variable (introduced to eliminate a local
+       reference) and it contains a type of unboxable numbers, then
+       force unboxing.  Indeed, if not boxed, each assignment to the variable
+       might require some boxing, but such local references are often
+       used in loops and we really want to avoid repeated boxing. *)
+    match str, kind with
+    | Mutable, Pfloatval ->
+        Boxed (Boxed_float Debuginfo.none, false)
+    | Mutable, Pboxedintval bi ->
+        Boxed (Boxed_integer (bi, Debuginfo.none), false)
+    | _, (Pfloatval | Pboxedintval _) ->
+        (* It would be safe to always unbox in this case, but
+           we do it only if this indeed allows us to get rid of
+           some allocations in the bound expression. *)
+        is_unboxed_number ~strict:false env exp
+    | _, Pgenval ->
+        (* Here we don't know statically that the bound expression
+           evaluates to an unboxable number type.  We need to be stricter
+           and ensure that all possible branches in the expression
+           return a boxed value (of the same kind).  Indeed, with GADTs,
+           different branches could return different types. *)
+        is_unboxed_number ~strict:true env exp
+    | _, Pintval ->
+        No_unboxing
+  in
+  match unboxing with
+  | No_unboxing | Boxed (_, true) ->
       Clet(id, transl env exp, transl env body)
   | No_result ->
       (* the let-bound expression never returns a value, we can ignore
          the body *)
       transl env exp
-  | Boxed boxed_number ->
+  | Boxed (boxed_number, _false) ->
       let unboxed_id = Ident.create (Ident.name id) in
       Clet(unboxed_id, transl_unbox_number env boxed_number exp,
            transl (add_unboxed_id id unboxed_id boxed_number env) body)
@@ -2404,18 +2484,18 @@ and transl_letrec env bindings cont =
   let bsz =
     List.map (fun (id, exp) -> (id, exp, expr_size Ident.empty exp)) bindings in
   let op_alloc prim sz =
-    Cop(Cextcall(prim, typ_val, true, Debuginfo.none), [int_const sz]) in
+    Cop(Cextcall(prim, typ_val, true, Debuginfo.none, None), [int_const sz]) in
   let rec init_blocks = function
     | [] -> fill_nonrec bsz
-    | (id, exp, RHS_block sz) :: rem ->
+    | (id, _exp, RHS_block sz) :: rem ->
         Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem)
-    | (id, exp, RHS_floatblock sz) :: rem ->
+    | (id, _exp, RHS_floatblock sz) :: rem ->
         Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem)
-    | (id, exp, RHS_nonrec) :: rem ->
+    | (id, _exp, RHS_nonrec) :: rem ->
         Clet (id, Cconst_int 0, init_blocks rem)
   and fill_nonrec = function
     | [] -> fill_blocks bsz
-    | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+    | (_id, _exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
         fill_nonrec rem
     | (id, exp, RHS_nonrec) :: rem ->
         Clet(id, transl env exp, fill_nonrec rem)
@@ -2423,10 +2503,11 @@ and transl_letrec env bindings cont =
     | [] -> cont
     | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
         let op =
-          Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
+          Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none,
+                None),
               [Cvar id; transl env exp]) in
         Csequence(op, fill_blocks rem)
-    | (id, exp, RHS_nonrec) :: rem ->
+    | (_id, _exp, RHS_nonrec) :: rem ->
         fill_blocks rem
   in init_blocks bsz
 
@@ -2461,7 +2542,7 @@ let rec transl_all_functions already_translated cont =
     else begin
       transl_all_functions
         (StringSet.add f.label already_translated)
-        (transl_function f :: cont)
+        ((f.dbg, transl_function f) :: cont)
     end
   with Queue.Empty ->
     cont, already_translated
@@ -2613,16 +2694,27 @@ let emit_all_constants cont =
   emit_constants cont constants
 
 let transl_all_functions_and_emit_all_constants cont =
-  let rec aux already_translated cont =
+  let rec aux already_translated cont translated_functions =
     if Compilenv.structured_constants () = [] &&
        Queue.is_empty functions
-    then cont
+    then cont, translated_functions
     else
-      let cont, set = transl_all_functions already_translated cont in
+      let translated_functions, already_translated =
+        transl_all_functions already_translated translated_functions
+      in
       let cont = emit_all_constants cont in
-      aux already_translated cont
+      aux already_translated cont translated_functions
+  in
+  let cont, translated_functions =
+    aux StringSet.empty cont []
   in
-  aux StringSet.empty cont
+  let translated_functions =
+    (* Sort functions according to source position *)
+    List.map snd
+      (List.sort (fun (dbg1, _) (dbg2, _) ->
+           Debuginfo.compare dbg1 dbg2) translated_functions)
+  in
+  translated_functions @ cont
 
 (* Build the NULL terminated array of gc roots *)
 
@@ -2902,15 +2994,15 @@ let rec intermediate_curry_functions arity num =
       fun_args = [arg, typ_val; clos, typ_val];
       fun_body =
          if arity - num > 2 && arity <= max_arity_optimized then
-           Cop(Calloc,
-               [alloc_closure_header 5;
+           Cop(Calloc Debuginfo.none,
+               [alloc_closure_header 5 Debuginfo.none;
                 Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
                 int_const (arity - num - 1);
                 Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app");
                 Cvar arg; Cvar clos])
          else
-           Cop(Calloc,
-                     [alloc_closure_header 4;
+           Cop(Calloc Debuginfo.none,
+                     [alloc_closure_header 4 Debuginfo.none;
                       Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
                       int_const 1; Cvar arg; Cvar clos]);
       fun_fast = true;
@@ -3036,6 +3128,18 @@ let frame_table namelist =
         List.map mksym namelist
         @ [cint_zero])
 
+(* Generate the master table of Spacetime shapes *)
+
+let spacetime_shapes namelist =
+  let mksym name =
+    Csymbol_address (
+      Compilenv.make_symbol ~unitname:name (Some "spacetime_shapes"))
+  in
+  Cdata(Cglobal_symbol "caml_spacetime_shapes" ::
+        Cdefine_symbol "caml_spacetime_shapes" ::
+        List.map mksym namelist
+        @ [cint_zero])
+
 (* Generate the table of module data and code segments *)
 
 let segment_table namelist symbol begname endname =

diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli
index 1843fac579fbf826765569a034b99cfed5047ded..8104afabea7a1efd5a2ef41794e9eac3c2d08488 100644 (file)
--- a/asmcomp/cmmgen.mli
+++ b/asmcomp/cmmgen.mli
@@ -31,7 +31,9 @@ val reference_symbols: string list -> Cmm.phrase
 val globals_map: (string * Digest.t * Digest.t * string list) list ->
   Cmm.phrase
 val frame_table: string list -> Cmm.phrase
+val spacetime_shapes: string list -> Cmm.phrase
 val data_segment_table: string list -> Cmm.phrase
 val code_segment_table: string list -> Cmm.phrase
 val predef_exception: int -> string -> Cmm.phrase
 val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase
+val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint

diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml
index 094cdb8907967a5c6d17be012837a9ecab31a505..e33acd066ca3bfd1c1a2c1757e92a5c2f9fcaede 100644 (file)
--- a/asmcomp/comballoc.ml
+++ b/asmcomp/comballoc.ml
@@ -26,18 +26,20 @@ type allocation_state =
 
 let allocated_size = function
     No_alloc -> 0
-  | Pending_alloc(reg, ofs) -> ofs
+  | Pending_alloc(_, ofs) -> ofs
 
 let rec combine i allocstate =
   match i.desc with
     Iend | Ireturn | Iexit _ | Iraise _ ->
       (i, allocated_size allocstate)
-  | Iop(Ialloc sz) ->
+  | Iop(Ialloc { words = sz; _ }) ->
       begin match allocstate with
         No_alloc ->
           let (newnext, newsz) =
             combine i.next (Pending_alloc(i.res.(0), sz)) in
-          (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0)
+          (instr_cons_debug (Iop(Ialloc {words = newsz; spacetime_index = 0;
+              label_after_call_gc = None; }))
+            i.arg i.res i.dbg newnext, 0)
       | Pending_alloc(reg, ofs) ->
           if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin
             let (newnext, newsz) =
@@ -47,15 +49,17 @@ let rec combine i allocstate =
           end else begin
             let (newnext, newsz) =
               combine i.next (Pending_alloc(i.res.(0), sz)) in
-            (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs)
+            (instr_cons_debug (Iop(Ialloc { words = newsz; spacetime_index = 0;
+                label_after_call_gc = None; }))
+              i.arg i.res i.dbg newnext, ofs)
           end
       end
-  | Iop(Icall_ind | Icall_imm _ | Iextcall _ |
-        Itailcall_ind | Itailcall_imm _) ->
+  | Iop(Icall_ind _ | Icall_imm _ | Iextcall _ |
+        Itailcall_ind _ | Itailcall_imm _) ->
       let newnext = combine_restart i.next in
       (instr_cons_debug i.desc i.arg i.res i.dbg newnext,
        allocated_size allocstate)
-  | Iop op ->
+  | Iop _ ->
       let (newnext, sz) = combine i.next allocstate in
       (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz)
   | Iifthenelse(test, ifso, ifnot) ->
@@ -88,4 +92,5 @@ and combine_restart i =
   let (newi, _) = combine i No_alloc in newi
 
 let fundecl f =
-  {f with fun_body = combine_restart f.fun_body}
+  if Config.spacetime then f
+  else {f with fun_body = combine_restart f.fun_body}

diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml
index 8133c3969cfdf1239113c747e760654d50b093b1..9847cb93079d6d06e997f68db61d8286d16a5a25 100644 (file)
--- a/asmcomp/compilenv.ml
+++ b/asmcomp/compilenv.ml
@@ -432,6 +432,10 @@ let function_label fv =
   in
   (concat_symbol unitname (Closure_id.unique_name fv))
 
+let require_global global_ident =
+  if not (Ident.is_predef_exn global_ident) then
+    ignore (get_global_info global_ident : Cmx_format.unit_infos option)
+
 (* Error report *)
 
 open Format

diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli
index 2974eae02a417a3774f0c826281a05fb8b6de8db..32813bdbdfc605c38dbca8b04c581f9b77fa07fd 100644 (file)
--- a/asmcomp/compilenv.mli
+++ b/asmcomp/compilenv.mli
@@ -142,6 +142,10 @@ val cache_unit_info: unit_infos -> unit
            honored by [symbol_for_global] and [global_approx]
            without looking at the corresponding .cmx file. *)
 
+val require_global: Ident.t -> unit
+        (* Enforce a link dependency of the current compilation
+           unit to the required module *)
+
 val read_library_info: string -> library_infos
 
 type error =

diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml
index 4570d8efcc241d405d4050ed04fdc3697e84d9aa..42981ded0503a20077bbb2dc10deca8c4ec21d6c 100644 (file)
--- a/asmcomp/deadcode.ml
+++ b/asmcomp/deadcode.ml
@@ -22,32 +22,38 @@ open Mach
    and a set of registers live "before" instruction [i]. *)
 
 let rec deadcode i =
+  let arg =
+    if Config.spacetime
+      && Mach.spacetime_node_hole_pointer_is_live_before i
+    then Array.append i.arg [| Proc.loc_spacetime_node_hole |]
+    else i.arg
+  in
   match i.desc with
-  | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) | Iraise _ ->
-      (i, Reg.add_set_array i.live i.arg)
+  | Iend | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) | Iraise _ ->
+      (i, Reg.add_set_array i.live arg)
   | Iop op ->
       let (s, before) = deadcode i.next in
       if Proc.op_is_pure op                     (* no side effects *)
       && Reg.disjoint_set_array before i.res    (* results are not used after *)
-      && not (Proc.regs_are_volatile i.arg)    (* no stack-like hard reg *)
+      && not (Proc.regs_are_volatile arg)      (* no stack-like hard reg *)
       && not (Proc.regs_are_volatile i.res)    (*            is involved *)
       then begin
         assert (Array.length i.res > 0);  (* sanity check *)
         (s, before)
       end else begin
-        ({i with next = s}, Reg.add_set_array i.live i.arg)
+        ({i with next = s}, Reg.add_set_array i.live arg)
       end
   | Iifthenelse(test, ifso, ifnot) ->
       let (ifso', _) = deadcode ifso in
       let (ifnot', _) = deadcode ifnot in
       let (s, _) = deadcode i.next in
       ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s},
-       Reg.add_set_array i.live i.arg)
+       Reg.add_set_array i.live arg)
   | Iswitch(index, cases) ->
       let cases' = Array.map (fun c -> fst (deadcode c)) cases in
       let (s, _) = deadcode i.next in
       ({i with desc = Iswitch(index, cases'); next = s},
-       Reg.add_set_array i.live i.arg)
+       Reg.add_set_array i.live arg)
   | Iloop(body) ->
       let (body', _) = deadcode body in
       let (s, _) = deadcode i.next in
@@ -57,7 +63,7 @@ let rec deadcode i =
       let (handler', _) = deadcode handler in
       let (s, _) = deadcode i.next in
       ({i with desc = Icatch(nfail, body', handler'); next = s}, i.live)
-  | Iexit nfail ->
+  | Iexit _ ->
       (i, i.live)
   | Itrywith(body, handler) ->
       let (body', _) = deadcode body in

diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index 4ba28d2a746d60d6f9d6a0b42a60050dc7b41f09..1149814aaf917192c08305a975d500261dc9fc12 100644 (file)
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -15,8 +15,6 @@
 
 (* Common functions for emitting assembly code *)
 
-open Debuginfo
-
 let output_channel = ref stdout
 
 let emit_string s = output_string !output_channel s
@@ -111,12 +109,14 @@ type frame_descr =
   { fd_lbl: int;                        (* Return address *)
     fd_frame_size: int;                 (* Size of stack frame *)
     fd_live_offset: int list;           (* Offsets/regs of live addresses *)
+    fd_raise: bool;                     (* Is frame for a raise? *)
     fd_debuginfo: Debuginfo.t }         (* Location, if any *)
 
 let frame_descriptors = ref([] : frame_descr list)
 
 type emit_frame_actions =
-  { efa_label: int -> unit;
+  { efa_code_label: int -> unit;
+    efa_data_label: int -> unit;
     efa_16: int -> unit;
     efa_32: int32 -> unit;
     efa_word: int -> unit;
@@ -131,39 +131,72 @@ let emit_frames a =
     try
       Hashtbl.find filenames name
     with Not_found ->
-      let lbl = Linearize.new_label () in
+      let lbl = Cmm.new_label () in
       Hashtbl.add filenames name lbl;
-      lbl in
+      lbl
+  in
+  let debuginfos = Hashtbl.create 7 in
+  let rec label_debuginfos rs rdbg =
+    let key = (rs, rdbg) in
+    try fst (Hashtbl.find debuginfos key)
+    with Not_found ->
+      let lbl = Cmm.new_label () in
+      let next =
+        match rdbg with
+        | [] -> assert false
+        | _ :: [] -> None
+        | _ :: ((_ :: _) as rdbg') -> Some (label_debuginfos false rdbg')
+      in
+      Hashtbl.add debuginfos key (lbl, next);
+      lbl
+  in
+  let emit_debuginfo_label rs rdbg =
+    a.efa_data_label (label_debuginfos rs rdbg)
+  in
   let emit_frame fd =
-    a.efa_label fd.fd_lbl;
+    a.efa_code_label fd.fd_lbl;
     a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo
               then fd.fd_frame_size
               else fd.fd_frame_size + 1);
     a.efa_16 (List.length fd.fd_live_offset);
     List.iter a.efa_16 fd.fd_live_offset;
     a.efa_align Arch.size_addr;
-    if not (Debuginfo.is_none fd.fd_debuginfo) then begin
-      let d = fd.fd_debuginfo in
-      let line = min 0xFFFFF d.dinfo_line
-      and char_start = min 0xFF d.dinfo_char_start
-      and char_end = min 0x3FF d.dinfo_char_end
-      and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in
-      let info =
-        Int64.add (Int64.shift_left (Int64.of_int line) 44) (
-        Int64.add (Int64.shift_left (Int64.of_int char_start) 36) (
-        Int64.add (Int64.shift_left (Int64.of_int char_end) 26)
-                  (Int64.of_int kind))) in
-      a.efa_label_rel
-        (label_filename d.dinfo_file)
-        (Int64.to_int32 info);
-      a.efa_32 (Int64.to_int32 (Int64.shift_right info 32))
-    end in
+    match List.rev fd.fd_debuginfo with
+    | [] -> ()
+    | _ :: _ as rdbg -> emit_debuginfo_label fd.fd_raise rdbg
+  in
   let emit_filename name lbl =
     a.efa_def_label lbl;
     a.efa_string name;
-    a.efa_align Arch.size_addr in
+    a.efa_align Arch.size_addr
+  in
+  let pack_info fd_raise d =
+    let line = min 0xFFFFF d.Debuginfo.dinfo_line
+    and char_start = min 0xFF d.Debuginfo.dinfo_char_start
+    and char_end = min 0x3FF d.Debuginfo.dinfo_char_end
+    and kind = if fd_raise then 1 else 0 in
+    Int64.(add (shift_left (of_int line) 44)
+             (add (shift_left (of_int char_start) 36)
+                (add (shift_left (of_int char_end) 26)
+                   (of_int kind))))
+  in
+  let emit_debuginfo (rs, rdbg) (lbl,next) =
+    let d = List.hd rdbg in
+    a.efa_align Arch.size_addr;
+    a.efa_def_label lbl;
+    let info = pack_info rs d in
+    a.efa_label_rel
+      (label_filename d.Debuginfo.dinfo_file)
+      (Int64.to_int32 info);
+    a.efa_32 (Int64.to_int32 (Int64.shift_right info 32));
+    begin match next with
+    | Some next -> a.efa_data_label next
+    | None -> a.efa_word 0
+    end
+  in
   a.efa_word (List.length !frame_descriptors);
   List.iter emit_frame !frame_descriptors;
+  Hashtbl.iter emit_debuginfo debuginfos;
   Hashtbl.iter emit_filename filenames;
   frame_descriptors := []
 
@@ -225,23 +258,23 @@ let reset_debug_info () =
    display .loc for every instruction. *)
 let emit_debug_info_gen dbg file_emitter loc_emitter =
   if is_cfi_enabled () &&
-    (!Clflags.debug || Config.with_frame_pointers)
-     && dbg.Debuginfo.dinfo_line > 0 (* PR#6243 *)
-  then begin
-    let { Debuginfo.
-          dinfo_line = line;
-          dinfo_char_start = col;
-          dinfo_file = file_name;
-        } = dbg in
-    let file_num =
-      try List.assoc file_name !file_pos_nums
-      with Not_found ->
-        let file_num = !file_pos_num_cnt in
-        incr file_pos_num_cnt;
-        file_emitter ~file_num ~file_name;
-        file_pos_nums := (file_name,file_num) :: !file_pos_nums;
-        file_num in
-    loc_emitter ~file_num ~line ~col;
+    (!Clflags.debug || Config.with_frame_pointers) then begin
+    match List.rev dbg with
+    | [] -> ()
+    | { Debuginfo.dinfo_line = line;
+        dinfo_char_start = col;
+        dinfo_file = file_name; } :: _ ->
+      if line > 0 then begin (* PR#6243 *)
+        let file_num =
+          try List.assoc file_name !file_pos_nums
+          with Not_found ->
+            let file_num = !file_pos_num_cnt in
+            incr file_pos_num_cnt;
+            file_emitter ~file_num ~file_name;
+            file_pos_nums := (file_name,file_num) :: !file_pos_nums;
+            file_num in
+        loc_emitter ~file_num ~line ~col;
+      end
   end
 
 let emit_debug_info dbg =

diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
index 093b589f1839a1059487e743fc3252e8a4103207..1e4addd32d00e0b25b1a078d05f7129ebf331f68 100644 (file)
--- a/asmcomp/emitaux.mli
+++ b/asmcomp/emitaux.mli
@@ -42,12 +42,14 @@ type frame_descr =
   { fd_lbl: int;                        (* Return address *)
     fd_frame_size: int;                 (* Size of stack frame *)
     fd_live_offset: int list;           (* Offsets/regs of live addresses *)
+    fd_raise: bool;                     (* Is frame for a raise? *)
     fd_debuginfo: Debuginfo.t }         (* Location, if any *)
 
 val frame_descriptors : frame_descr list ref
 
 type emit_frame_actions =
-  { efa_label: int -> unit;
+  { efa_code_label: int -> unit;
+    efa_data_label: int -> unit;
     efa_16: int -> unit;
     efa_32: int32 -> unit;
     efa_word: int -> unit;

diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml
index a5a0bd76a880d8817721d1b4c982f131fd228598..9ae0ecf95793bacb40e35239d21973f8dd4b4414 100644 (file)
--- a/asmcomp/flambda_to_clambda.ml
+++ b/asmcomp/flambda_to_clambda.ml
@@ -230,33 +230,18 @@ let to_clambda_const env (const : Flambda.constant_defining_value_block_field)
   | Const (Char c) -> Uconst_int (Char.code c)
   | Const (Const_pointer i) -> Uconst_ptr i
 
-(* CR-someday mshinwell: We should improve debug info / location handling
-   so that we don't need to do this. *)
-(* Erase debug info created with high probability by [Debuginfo.from_filename]
-   (currently only used for emission of warning 59, which happens prior to
-   this pass).  Failure to do this will cause erroneous empty frames in
-   backtraces. *)
-let erase_empty_debuginfo (dbg : Debuginfo.t) =
-  if dbg.dinfo_kind = Debuginfo.Dinfo_call
-    && dbg.dinfo_line = 0
-    && dbg.dinfo_char_start = 0
-    && dbg.dinfo_char_end = 0
-  then
-    Debuginfo.none
-  else
-    dbg
-
 let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
   match flam with
   | Var var -> subst_var env var
   | Let { var; defining_expr; body; _ } ->
+    (* TODO: synthesize proper value_kind *)
     let id, env_body = Env.add_fresh_ident env var in
-    Ulet (id, to_clambda_named t env var defining_expr,
+    Ulet (Immutable, Pgenval, id, to_clambda_named t env var defining_expr,
       to_clambda t env_body body)
-  | Let_mutable (mut_var, var, body) ->
+  | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } ->
     let id, env_body = Env.add_fresh_mutable_ident env mut_var in
     let def = subst_var env var in
-    Ulet (id, def, to_clambda t env_body body)
+    Ulet (Mutable, contents_kind, id, def, to_clambda t env_body body)
   | Let_rec (defs, body) ->
     let env, defs =
       List.fold_right (fun (var, def) (env, defs) ->
@@ -408,19 +393,15 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
       [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)],
       Debuginfo.none)
   | Prim (Pfield index, [block], dbg) ->
-    let dbg = erase_empty_debuginfo dbg in
     Uprim (Pfield index, [check_field (subst_var env block) index None], dbg)
   | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
-    let dbg = erase_empty_debuginfo dbg in
     Uprim (Psetfield (index, maybe_ptr, init), [
         check_field (subst_var env block) index None;
         subst_var env new_value;
       ], dbg)
   | Prim (Popaque, args, dbg) ->
-    let dbg = erase_empty_debuginfo dbg in
     Uprim (Pidentity, subst_vars env args, dbg)
   | Prim (p, args, dbg) ->
-    let dbg = erase_empty_debuginfo dbg in
     Uprim (p, subst_vars env args, dbg)
   | Expr expr -> to_clambda t env expr
 

diff --git a/asmcomp/i386/CSE.ml b/asmcomp/i386/CSE.ml
index 85c7223f6499eb827ae3d6948ba28c88bda51166..6ef8fec6403ef002f4af339005ecd4db6b8556ac 100644 (file)
--- a/asmcomp/i386/CSE.ml
+++ b/asmcomp/i386/CSE.ml
@@ -20,7 +20,7 @@ open Arch
 open Mach
 open CSEgen
 
-class cse = object (self)
+class cse = object
 
 inherit cse_generic as super
 
@@ -40,7 +40,7 @@ method! class_of_operation op =
 
 method! is_cheap_operation op =
   match op with
-  | Iconst_int _ | Iconst_blockheader _ -> true
+  | Iconst_int _ -> true
   | Iconst_symbol _ -> true
   | _ -> false
 

diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml
index b17188afc28bfeb02511f13bc90986bc3182421d..23f54232a44eb4821a20da2dcfaf9e39c77ba640 100644 (file)
--- a/asmcomp/i386/arch.ml
+++ b/asmcomp/i386/arch.ml
@@ -52,6 +52,8 @@ type specific_operation =
 and float_operation =
     Ifloatadd | Ifloatsub | Ifloatsubrev | Ifloatmul | Ifloatdiv | Ifloatdivrev
 
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
 (* Sizes, endianness *)
 
 let big_endian = false
@@ -79,11 +81,11 @@ let offset_addressing addr delta =
   | Iindexed2scaled(scale, n) -> Iindexed2scaled(scale, n + delta)
 
 let num_args_addressing = function
-    Ibased(s, n) -> 0
-  | Iindexed n -> 1
-  | Iindexed2 n -> 2
-  | Iscaled(scale, n) -> 1
-  | Iindexed2scaled(scale, n) -> 2
+    Ibased _ -> 0
+  | Iindexed _ -> 1
+  | Iindexed2 _ -> 2
+  | Iscaled _ -> 1
+  | Iindexed2scaled _ -> 2
 
 (* Printing operations and addressing modes *)
 

diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index 2a261fb6d185dedaf0446e92aa860367c0fdbec3..d3325e1d0cdd886d11deacadff9d219e57016861 100644 (file)
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -116,9 +116,6 @@ let label_prefix =
 let emit_label lbl =
   Printf.sprintf "%s%d" label_prefix lbl
 
-let emit_data_label lbl =
-  Printf.sprintf "%sd%d" label_prefix lbl
-
 let label s = sym (emit_label s)
 
 let def_label s = D.label (emit_label s)
@@ -193,8 +190,12 @@ let addressing addr typ i n =
 
 (* Record live pointers at call points *)
 
-let record_frame_label live dbg =
-  let lbl = new_label() in
+let record_frame_label ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -210,11 +211,12 @@ let record_frame_label live dbg =
     { fd_lbl = lbl;
       fd_frame_size = frame_size();
       fd_live_offset = !live_offset;
+      fd_raise = raise_;
       fd_debuginfo = dbg } :: !frame_descriptors;
   lbl
 
-let record_frame live dbg =
-  let lbl = record_frame_label live dbg in
+let record_frame ?label live raise_ dbg =
+  let lbl = record_frame_label ?label live raise_ dbg in
   def_label lbl
 
 (* Record calls to the GC -- we've moved them out of the way *)
@@ -243,10 +245,10 @@ type bound_error_call =
 let bound_error_sites = ref ([] : bound_error_call list)
 let bound_error_call = ref 0
 
-let bound_error_label dbg =
+let bound_error_label ?label dbg =
   if !Clflags.debug then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame_label Reg.Set.empty dbg in
+    let lbl_frame = record_frame_label ?label Reg.Set.empty false dbg in
     bound_error_sites :=
       { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
     lbl_bound_error
@@ -496,7 +498,7 @@ let emit_instr fallthrough i =
         else
           I.mov (reg src) (reg dst)
       end
-  | Lop(Iconst_int n | Iconst_blockheader n) ->
+  | Lop(Iconst_int n) ->
       if n = 0n then begin
         match i.res.(0).loc with
         | Reg _ -> I.xor (reg i.res.(0)) (reg i.res.(0))
@@ -520,46 +522,46 @@ let emit_instr fallthrough i =
   | Lop(Iconst_symbol s) ->
       add_used_symbol s;
       I.mov (immsym s) (reg i.res.(0))
-  | Lop(Icall_ind) ->
+  | Lop(Icall_ind { label_after; }) ->
       I.call (reg i.arg.(0));
-      record_frame i.live i.dbg
-  | Lop(Icall_imm s) ->
-      add_used_symbol s;
-      emit_call s;
-      record_frame i.live i.dbg
-  | Lop(Itailcall_ind) ->
+      record_frame i.live false i.dbg ~label:label_after
+  | Lop(Icall_imm { func; label_after; }) ->
+      add_used_symbol func;
+      emit_call func;
+      record_frame i.live false i.dbg ~label:label_after
+  | Lop(Itailcall_ind { label_after = _; }) ->
       output_epilogue begin fun () ->
         I.jmp (reg i.arg.(0))
       end
-  | Lop(Itailcall_imm s) ->
-      if s = !function_name then
+  | Lop(Itailcall_imm { func; label_after = _; }) ->
+      if func = !function_name then
         I.jmp (label !tailrec_entry_point)
       else begin
         output_epilogue begin fun () ->
-          add_used_symbol s;
-          I.jmp (immsym s)
+          add_used_symbol func;
+          I.jmp (immsym func)
         end
       end
-  | Lop(Iextcall(s, alloc)) ->
-      add_used_symbol s;
+  | Lop(Iextcall { func; alloc; label_after; }) ->
+      add_used_symbol func;
       if alloc then begin
         if system <> S_macosx then
-          I.mov (immsym s) eax
+          I.mov (immsym func) eax
         else begin
           external_symbols_indirect :=
-            StringSet.add s !external_symbols_indirect;
+            StringSet.add func !external_symbols_indirect;
           I.mov (mem_sym DWORD (Printf.sprintf "L%s$non_lazy_ptr"
-                              (emit_symbol s))) eax
+                              (emit_symbol func))) eax
         end;
         emit_call "caml_c_call";
-        record_frame i.live i.dbg
+        record_frame i.live false i.dbg ~label:label_after
       end else begin
         if system <> S_macosx then
-          emit_call s
+          emit_call func
         else begin
           external_symbols_direct :=
-            StringSet.add s !external_symbols_direct;
-          I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol s)))
+            StringSet.add func !external_symbols_direct;
+          I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol func)))
         end
       end
   | Lop(Istackoffset n) ->
@@ -609,7 +611,7 @@ let emit_instr fallthrough i =
             I.fstp (addressing addr REAL8 i 1)
           end
       end
-  | Lop(Ialloc n) ->
+  | Lop(Ialloc { words = n; label_after_call_gc; }) ->
       if !fastcode_flag then begin
         let lbl_redo = new_label() in
         def_label lbl_redo;
@@ -618,7 +620,7 @@ let emit_instr fallthrough i =
         I.mov eax (sym32 "caml_young_ptr");
         I.cmp (sym32 "caml_young_limit") eax;
         let lbl_call_gc = new_label() in
-        let lbl_frame = record_frame_label i.live Debuginfo.none in
+        let lbl_frame = record_frame_label i.live false Debuginfo.none in
         I.jb (label lbl_call_gc);
         I.lea (mem32 NONE 4 RAX) (reg i.res.(0));
         call_gc_sites :=
@@ -634,7 +636,11 @@ let emit_instr fallthrough i =
             I.mov (int n) eax;
             emit_call "caml_allocN"
         end;
-        record_frame i.live Debuginfo.none;
+        let label =
+          record_frame_label ?label:label_after_call_gc i.live false
+            Debuginfo.none
+        in
+        def_label label;
         I.lea (mem32 NONE 4 RAX) (reg i.res.(0))
       end
   | Lop(Iintop(Icomp cmp)) ->
@@ -645,12 +651,12 @@ let emit_instr fallthrough i =
       I.cmp (int n) (reg i.arg.(0));
       I.set (cond cmp) al;
       I.movzx al (reg i.res.(0))
-  | Lop(Iintop Icheckbound) ->
-      let lbl = bound_error_label i.dbg in
+  | Lop(Iintop (Icheckbound { label_after_error; } )) ->
+      let lbl = bound_error_label ?label:label_after_error i.dbg in
       I.cmp (reg i.arg.(1)) (reg i.arg.(0));
       I.jbe (label lbl)
-  | Lop(Iintop_imm(Icheckbound, n)) ->
-      let lbl = bound_error_label i.dbg in
+  | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+      let lbl = bound_error_label ?label:label_after_error i.dbg in
       I.cmp (int n) (reg i.arg.(0));
       I.jbe (label lbl)
   | Lop(Iintop(Idiv | Imod)) ->
@@ -869,15 +875,11 @@ let emit_instr fallthrough i =
       cfi_adjust_cfa_offset (-trap_frame_size);
       stack_offset := !stack_offset - trap_frame_size
   | Lraise k  ->
-      begin match !Clflags.debug, k with
-      | true, Lambda.Raise_regular ->
+      begin match k with
+      | Cmm.Raise_withtrace ->
           emit_call "caml_raise_exn";
-          record_frame Reg.Set.empty i.dbg
-      | true, Lambda.Raise_reraise ->
-          emit_call "caml_reraise_exn";
-          record_frame Reg.Set.empty i.dbg
-      | false, _
-      | true, Lambda.Raise_notrace ->
+          record_frame Reg.Set.empty true i.dbg
+      | Cmm.Raise_notrace ->
           I.mov (sym32 "caml_exception_pointer") esp;
           I.pop (sym32 "caml_exception_pointer");
           if trap_frame_size > 8 then
@@ -989,7 +991,6 @@ let fundecl fundecl =
 let emit_item = function
   | Cglobal_symbol s -> D.global (emit_symbol s)
   | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s)
-  | Cdefine_label lbl -> _label (emit_data_label lbl)
   | Cint8 n -> D.byte (const n)
   | Cint16 n -> D.word (const n)
   | Cint32 n -> D.long (const_nat n)
@@ -997,7 +998,6 @@ let emit_item = function
   | Csingle f -> D.long (Const (Int64.of_int32 (Int32.bits_of_float f)))
   | Cdouble f -> emit_float64_split_directive (Int64.bits_of_float f)
   | Csymbol_address s -> add_used_symbol s; D.long (ConstLabel (emit_symbol s))
-  | Clabel_address lbl -> D.long (ConstLabel (emit_data_label lbl))
   | Cstring s -> D.bytes s
   | Cskip n -> if n > 0 then D.space n
   | Calign n -> D.align n
@@ -1027,7 +1027,6 @@ let begin_assembly() =
     D.extrn "_caml_alloc3" PROC;
     D.extrn "_caml_ml_array_bound_error" PROC;
     D.extrn "_caml_raise_exn" PROC;
-    D.extrn "_caml_reraise_exn" PROC;
   end;
 
   D.data ();
@@ -1057,7 +1056,8 @@ let end_assembly() =
   emit_global_label "frametable";
 
   emit_frames
-    { efa_label = (fun l -> D.long (ConstLabel (emit_label l)));
+    { efa_code_label = (fun l -> D.long (ConstLabel (emit_label l)));
+      efa_data_label = (fun l -> D.long (ConstLabel (emit_label l)));
       efa_16 = (fun n -> D.word (const n));
       efa_32 = (fun n -> D.long (const_32 n));
       efa_word = (fun n -> D.long (const n));

diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml
index b7e17843a8cc490fc305006a9c287c562a8475b8..9350fc96d4ffa5f4c32db7346a0aa78fac6692e6 100644 (file)
--- a/asmcomp/i386/proc.ml
+++ b/asmcomp/i386/proc.ml
@@ -94,6 +94,8 @@ let edx = phys_reg 3
 let stack_slot slot ty =
   Reg.at_location ty (Stack slot)
 
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
 (* Instruction selection *)
 
 let word_addressed = false
@@ -140,7 +142,7 @@ let calling_conventions first_int last_int first_float last_float make_stack
 
 let incoming ofs = Incoming ofs
 let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
 
 (* Six arguments in integer registers plus eight in global memory. *)
 let max_arguments_for_tailcalls = 14
@@ -148,16 +150,16 @@ let max_arguments_for_tailcalls = 14
 let loc_arguments arg =
   calling_conventions 0 5 100 99 outgoing arg
 let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc
+  let (loc, _ofs) = calling_conventions 0 5 100 99 incoming arg in loc
 let loc_results res =
-  let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc
-let loc_external_arguments arg =
+  let (loc, _ofs) = calling_conventions 0 5 100 100 not_supported res in loc
+let loc_external_arguments _arg =
   fatal_error "Proc.loc_external_arguments"
 let loc_external_results res =
   match res with
   | [|{typ=Int};{typ=Int}|] -> [|eax; edx|]
   | _ ->
-      let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
+      let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported res in loc
 
 let loc_exn_bucket = eax
 
@@ -182,8 +184,9 @@ let destroyed_at_c_call =               (* ebx, esi, edi, ebp preserved *)
   [|eax; ecx; edx|]
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _}) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
   | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |]
   | Iop(Ialloc _ | Iintop Imulh) -> [| eax |]
   | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
@@ -195,10 +198,10 @@ let destroyed_at_raise = all_phys_regs
 
 (* Maximal register pressure *)
 
-let safe_register_pressure op = 4
+let safe_register_pressure _op = 4
 
 let max_register_pressure = function
-    Iextcall(_, _) -> [| 4; max_int |]
+    Iextcall _ -> [| 4; max_int |]
   | Iintop(Idiv | Imod) -> [| 5; max_int |]
   | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) |
     Iintoffloat -> [| 6; max_int |]
@@ -208,9 +211,9 @@ let max_register_pressure = function
    registers).  *)
 
 let op_is_pure = function
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
   | Ispecific(Ilea _) -> true
   | Ispecific _ -> false
   | _ -> true

diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml
index 67f3e5712ca683d609e9d1609f6483c431f4aed5..511b7f1bd6a4a0224e65a9a6165940caf855b820 100644 (file)
--- a/asmcomp/i386/reload.ml
+++ b/asmcomp/i386/reload.ml
@@ -40,7 +40,7 @@ method! makereg r =
 
 method! reload_operation op arg res =
   match op with
-    Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound) ->
+    Iintop(Iadd|Isub|Iand|Ior|Ixor|Icomp _|Icheckbound _) ->
       (* One of the two arguments can reside in the stack *)
       if stackp arg.(0) && stackp arg.(1)
       then ([|arg.(0); self#makereg arg.(1)|], res)
@@ -71,7 +71,7 @@ method! reload_operation op arg res =
 
 method! reload_test tst arg =
   match tst with
-    Iinttest cmp ->
+    Iinttest _ ->
       (* One of the two arguments can reside on stack *)
       if stackp arg.(0) && stackp arg.(1)
       then [| self#makereg arg.(0); arg.(1) |]

diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml
index f37781d2a86ede6b7a00c2ee1aa49f1d0a1dcc75..16199ca641684e5d7124c5e2e1c0c66ab3866db2 100644 (file)
--- a/asmcomp/i386/selection.ml
+++ b/asmcomp/i386/selection.ml
@@ -88,7 +88,7 @@ let rec float_needs = function
       let n1 = float_needs arg1 in
       let n2 = float_needs arg2 in
       if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2
-  | Cop(Cextcall(fn, ty_res, alloc, dbg), args)
+  | Cop(Cextcall(fn, _ty_res, _alloc, _dbg, _label), args)
     when !fast_math && List.mem fn inline_float_ops ->
       begin match args with
         [arg] -> float_needs arg
@@ -138,7 +138,7 @@ let pseudoregs_for_operation op arg res =
   (* For storing a byte, the argument must be in eax...edx.
      (But for a short, any reg will do!)
      Keep it simple, just force the argument to be in edx. *)
-  | Istore((Byte_unsigned | Byte_signed), addr, _) ->
+  | Istore((Byte_unsigned | Byte_signed), _, _) ->
       let newarg = Array.copy arg in
       newarg.(0) <- edx;
       (newarg, res, false)
@@ -157,18 +157,18 @@ class selector = object (self)
 
 inherit Selectgen.selector_generic as super
 
-method is_immediate (n : int) = true
+method is_immediate (_n : int) = true
 
 method! is_simple_expr e =
   match e with
-  | Cop(Cextcall(fn, _, alloc, _), args)
+  | Cop(Cextcall(fn, _, _, _, _), args)
     when !fast_math && List.mem fn inline_float_ops ->
       (* inlined float ops are simple if their arguments are *)
       List.for_all self#is_simple_expr args
   | _ ->
       super#is_simple_expr e
 
-method select_addressing chunk exp =
+method select_addressing _chunk exp =
   match select_addr exp with
     (Asymbol s, d) ->
       (Ibased(s, d), Ctuple [])
@@ -185,7 +185,7 @@ method! select_store is_assign addr exp =
   match exp with
     Cconst_int n ->
       (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
-  | (Cconst_natint n | Cconst_blockheader n) ->
+  | (Cconst_natint n | Cblockheader (n, _)) ->
       (Ispecific(Istore_int(n, addr, is_assign)), Ctuple [])
   | Cconst_pointer n ->
       (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple [])
@@ -201,7 +201,7 @@ method! select_operation op args =
   (* Recognize the LEA instruction *)
     Caddi | Caddv | Cadda | Csubi ->
       begin match self#select_addressing Word_int (Cop(op, args)) with
-        (Iindexed d, _) -> super#select_operation op args
+        (Iindexed _, _)
       | (Iindexed2 0, _) -> super#select_operation op args
       | (addr, arg) -> (Ispecific(Ilea addr), [arg])
       end
@@ -228,7 +228,7 @@ method! select_operation op args =
           super#select_operation op args
       end
   (* Recognize inlined floating point operations *)
-  | Cextcall(fn, ty_res, false, dbg)
+  | Cextcall(fn, _ty_res, false, _dbg, _label)
     when !fast_math && List.mem fn inline_float_ops ->
       (Ispecific(Ifloatspecial fn), args)
   (* i386 does not support immediate operands for multiply high signed *)

diff --git a/asmcomp/import_approx.ml b/asmcomp/import_approx.ml
index 34a0b85f134285bdbfc9f8ff3af9ef60cd417ba7..7b4fef9cc3772014afa92c8ec066ff9324e5bb6b 100644 (file)
--- a/asmcomp/import_approx.ml
+++ b/asmcomp/import_approx.ml
@@ -104,7 +104,11 @@ let rec import_ex ex =
     | Unknown_or_mutable ->
       A.value_mutable_float_array ~size:float_array.size
     | Contents contents ->
-      A.value_immutable_float_array contents
+      A.value_immutable_float_array
+        (Array.map (function
+           | None -> A.value_any_float
+           | Some f -> A.value_float f)
+           contents)
     end
   | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i
   | Value_string { size; contents } ->

diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml
index 2376aa21969d8d65e9de7db6e6583b913efc1713..28f00c11b21cd7ba0e0d78e79ce5e9840c50299b 100644 (file)
--- a/asmcomp/interf.ml
+++ b/asmcomp/interf.ml
@@ -90,17 +90,17 @@ let build_graph fundecl =
     | Iop(Imove | Ispill | Ireload) ->
         add_interf_move i.arg.(0) i.res.(0) i.live;
         interf i.next
-    | Iop(Itailcall_ind) -> ()
-    | Iop(Itailcall_imm lbl) -> ()
-    | Iop op ->
+    | Iop(Itailcall_ind _) -> ()
+    | Iop(Itailcall_imm _) -> ()
+    | Iop _ ->
         add_interf_set i.res i.live;
         add_interf_self i.res;
         interf i.next
-    | Iifthenelse(tst, ifso, ifnot) ->
+    | Iifthenelse(_tst, ifso, ifnot) ->
         interf ifso;
         interf ifnot;
         interf i.next
-    | Iswitch(index, cases) ->
+    | Iswitch(_index, cases) ->
         for i = 0 to Array.length cases - 1 do
           interf cases.(i)
         done;
@@ -162,15 +162,15 @@ let build_graph fundecl =
     | Iop(Ireload) ->
         add_pref (weight / 4) i.res.(0) i.arg.(0);
         prefer weight i.next
-    | Iop(Itailcall_ind) -> ()
-    | Iop(Itailcall_imm lbl) -> ()
-    | Iop op ->
+    | Iop(Itailcall_ind _) -> ()
+    | Iop(Itailcall_imm _) -> ()
+    | Iop _ ->
         prefer weight i.next
-    | Iifthenelse(tst, ifso, ifnot) ->
+    | Iifthenelse(_tst, ifso, ifnot) ->
         prefer (weight / 2) ifso;
         prefer (weight / 2) ifnot;
         prefer weight i.next
-    | Iswitch(index, cases) ->
+    | Iswitch(_index, cases) ->
         for i = 0 to Array.length cases - 1 do
           prefer (weight / 2) cases.(i)
         done;

diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml
index 7cf99fe15e45aeb7127449f94c9ac163b0690d14..44df185ca1ddb7c97b6f7164b32ba4778069a364 100644 (file)
--- a/asmcomp/linearize.ml
+++ b/asmcomp/linearize.ml
@@ -18,11 +18,7 @@
 open Reg
 open Mach
 
-type label = int
-
-let label_counter = ref 99
-
-let new_label() = incr label_counter; !label_counter
+type label = Cmm.label
 
 type instruction =
   { mutable desc: instruction_desc;
@@ -45,18 +41,20 @@ and instruction_desc =
   | Lsetuptrap of label
   | Lpushtrap
   | Lpoptrap
-  | Lraise of Lambda.raise_kind
+  | Lraise of Cmm.raise_kind
 
 let has_fallthrough = function
   | Lreturn | Lbranch _ | Lswitch _ | Lraise _
-  | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false
+  | Lop Itailcall_ind _ | Lop (Itailcall_imm _) -> false
   | _ -> true
 
 type fundecl =
   { fun_name: string;
     fun_body: instruction;
     fun_fast: bool;
-    fun_dbg : Debuginfo.t }
+    fun_dbg : Debuginfo.t;
+    fun_spacetime_shape : Mach.spacetime_shape option;
+  }
 
 (* Invert a test *)
 
@@ -113,7 +111,7 @@ let get_label n = match n.desc with
     Lbranch lbl -> (lbl, n)
   | Llabel lbl -> (lbl, n)
   | Lend -> (-1, n)
-  | _ -> let lbl = new_label() in (lbl, cons_instr (Llabel lbl) n)
+  | _ -> let lbl = Cmm.new_label() in (lbl, cons_instr (Llabel lbl) n)
 
 (* Check the fallthrough label *)
 let check_label n = match n.desc with
@@ -180,8 +178,11 @@ let local_exit k =
 let rec linear i n =
   match i.Mach.desc with
     Iend -> n
-  | Iop(Itailcall_ind | Itailcall_imm _ as op) ->
-      copy_instr (Lop op) i (discard_dead_code n)
+  | Iop(Itailcall_ind _ | Itailcall_imm _ as op) ->
+      if not Config.spacetime then
+        copy_instr (Lop op) i (discard_dead_code n)
+      else
+        copy_instr (Lop op) i (linear i.Mach.next n)
   | Iop(Imove | Ireload | Ispill)
     when i.Mach.arg.(0).loc = i.Mach.res.(0).loc ->
       linear i.Mach.next n
@@ -248,7 +249,7 @@ let rec linear i n =
       end else
         copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2
   | Iloop body ->
-      let lbl_head = new_label() in
+      let lbl_head = Cmm.new_label() in
       let n1 = linear i.Mach.next n in
       let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in
       cons_instr (Llabel lbl_head) n2
@@ -280,21 +281,20 @@ let rec linear i n =
   | Itrywith(body, handler) ->
       let (lbl_join, n1) = get_label (linear i.Mach.next n) in
       incr try_depth;
+      assert (i.Mach.arg = [| |] || Config.spacetime);
       let (lbl_body, n2) =
-        get_label (cons_instr Lpushtrap
+        get_label (instr_cons Lpushtrap i.Mach.arg [| |]
                     (linear body (cons_instr Lpoptrap n1))) in
       decr try_depth;
-      cons_instr (Lsetuptrap lbl_body)
+      instr_cons (Lsetuptrap lbl_body) i.Mach.arg [| |]
         (linear handler (add_branch lbl_join n2))
   | Iraise k ->
       copy_instr (Lraise k) i (discard_dead_code n)
 
-let reset () =
-  label_counter := 99;
-  exit_label := []
-
 let fundecl f =
   { fun_name = f.Mach.fun_name;
     fun_body = linear f.Mach.fun_body end_instr;
     fun_fast = f.Mach.fun_fast;
-    fun_dbg  = f.Mach.fun_dbg }
+    fun_dbg  = f.Mach.fun_dbg;
+    fun_spacetime_shape = f.Mach.fun_spacetime_shape;
+  }

diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli
index 6d6d01cb520c43d919b9bbe1137ed7f5874a7423..850fbd89a88780fce6453d8ffac6f579aab83dba 100644 (file)
--- a/asmcomp/linearize.mli
+++ b/asmcomp/linearize.mli
@@ -15,8 +15,7 @@
 
 (* Transformation of Mach code into a list of pseudo-instructions. *)
 
-type label = int
-val new_label: unit -> label
+type label = Cmm.label
 
 type instruction =
   { mutable desc: instruction_desc;
@@ -39,7 +38,7 @@ and instruction_desc =
   | Lsetuptrap of label
   | Lpushtrap
   | Lpoptrap
-  | Lraise of Lambda.raise_kind
+  | Lraise of Cmm.raise_kind
 
 val has_fallthrough :  instruction_desc -> bool
 val end_instr: instruction
@@ -51,7 +50,8 @@ type fundecl =
   { fun_name: string;
     fun_body: instruction;
     fun_fast: bool;
-    fun_dbg : Debuginfo.t }
+    fun_dbg : Debuginfo.t;
+    fun_spacetime_shape : Mach.spacetime_shape option;
+  }
 
-val reset : unit -> unit
 val fundecl: Mach.fundecl -> fundecl

diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml
index 1ce943ab5e583deb97c4dad6351b8809a7ba93a4..c3d2f878840870ef5fe4be7ffe2816ff505c62b9 100644 (file)
--- a/asmcomp/liveness.ml
+++ b/asmcomp/liveness.ml
@@ -35,18 +35,24 @@ let rec live i finally =
      before the instruction sequence.
      The instruction i is annotated by the set of registers live across
      the instruction. *)
+  let arg =
+    if Config.spacetime
+      && Mach.spacetime_node_hole_pointer_is_live_before i
+    then Array.append i.arg [| Proc.loc_spacetime_node_hole |]
+    else i.arg
+  in
   match i.desc with
     Iend ->
       i.live <- finally;
       finally
-  | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
+  | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) ->
       i.live <- Reg.Set.empty; (* no regs are live across *)
-      Reg.set_of_array i.arg
+      Reg.set_of_array arg
   | Iop op ->
       let after = live i.next finally in
       if Proc.op_is_pure op                    (* no side effects *)
       && Reg.disjoint_set_array after i.res    (* results are not used after *)
-      && not (Proc.regs_are_volatile i.arg)    (* no stack-like hard reg *)
+      && not (Proc.regs_are_volatile arg)      (* no stack-like hard reg *)
       && not (Proc.regs_are_volatile i.res)    (*            is involved *)
       then begin
         (* This operation is dead code.  Ignore its arguments. *)
@@ -56,8 +62,8 @@ let rec live i finally =
         let across_after = Reg.diff_set_array after i.res in
         let across =
           match op with
-          | Icall_ind | Icall_imm _ | Iextcall _
-          | Iintop Icheckbound | Iintop_imm(Icheckbound, _) ->
+          | Icall_ind _ | Icall_imm _ | Iextcall _
+          | Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _) ->
               (* The function call may raise an exception, branching to the
                  nearest enclosing try ... with. Similarly for bounds checks.
                  Hence, everything that must be live at the beginning of
@@ -66,21 +72,21 @@ let rec live i finally =
            | _ ->
                across_after in
         i.live <- across;
-        Reg.add_set_array across i.arg
+        Reg.add_set_array across arg
       end
-  | Iifthenelse(test, ifso, ifnot) ->
+  | Iifthenelse(_test, ifso, ifnot) ->
       let at_join = live i.next finally in
       let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in
       i.live <- at_fork;
-      Reg.add_set_array at_fork i.arg
-  | Iswitch(index, cases) ->
+      Reg.add_set_array at_fork arg
+  | Iswitch(_index, cases) ->
       let at_join = live i.next finally in
       let at_fork = ref Reg.Set.empty in
       for i = 0 to Array.length cases - 1 do
         at_fork := Reg.Set.union !at_fork (live cases.(i) at_join)
       done;
       i.live <- !at_fork;
-      Reg.add_set_array !at_fork i.arg
+      Reg.add_set_array !at_fork arg
   | Iloop(body) ->
       let at_top = ref Reg.Set.empty in
       (* Yes, there are better algorithms, but we'll just iterate till
@@ -120,7 +126,7 @@ let rec live i finally =
       before_body
   | Iraise _ ->
       i.live <- !live_at_raise;
-      Reg.add_set_array !live_at_raise i.arg
+      Reg.add_set_array !live_at_raise arg
 
 let reset () =
   live_at_raise := Reg.Set.empty;
@@ -128,8 +134,13 @@ let reset () =
 
 let fundecl ppf f =
   let initially_live = live f.fun_body Reg.Set.empty in
-  (* Sanity check: only function parameters can be live at entrypoint *)
+  (* Sanity check: only function parameters (and the Spacetime node hole
+     register, if profiling) can be live at entrypoint *)
   let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in
+  let wrong_live =
+    if not Config.spacetime then wrong_live
+    else Reg.Set.remove Proc.loc_spacetime_node_hole wrong_live
+  in
   if not (Reg.Set.is_empty wrong_live) then begin
     Format.fprintf ppf "%a@." Printmach.regset wrong_live;
     Misc.fatal_error "Liveness.fundecl"

diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index 0770b988b3ded8186c5e25cd1fb2520bce226a66..d1e0b3bdfecd83c0aee2a10eb66a42faee7ff6c4 100644 (file)
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -15,6 +15,8 @@
 
 (* Representation of machine code by sequences of pseudoinstructions *)
 
+type label = Cmm.label
+
 type integer_comparison =
     Isigned of Cmm.comparison
   | Iunsigned of Cmm.comparison
@@ -23,7 +25,8 @@ type integer_operation =
     Iadd | Isub | Imul | Imulh | Idiv | Imod
   | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
   | Icomp of integer_comparison
-  | Icheckbound
+  | Icheckbound of { label_after_error : label option;
+        spacetime_index : int; }
 
 type test =
     Itruetest
@@ -41,16 +44,16 @@ type operation =
   | Iconst_int of nativeint
   | Iconst_float of int64
   | Iconst_symbol of string
-  | Iconst_blockheader of nativeint
-  | Icall_ind
-  | Icall_imm of string
-  | Itailcall_ind
-  | Itailcall_imm of string
-  | Iextcall of string * bool
+  | Icall_ind of { label_after : label; }
+  | Icall_imm of { func : string; label_after : label; }
+  | Itailcall_ind of { label_after : label; }
+  | Itailcall_imm of { func : string; label_after : label; }
+  | Iextcall of { func : string; alloc : bool; label_after : label; }
   | Istackoffset of int
   | Iload of Cmm.memory_chunk * Arch.addressing_mode
   | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
-  | Ialloc of int
+  | Ialloc of { words : int; label_after_call_gc : label option;
+        spacetime_index : int; }
   | Iintop of integer_operation
   | Iintop_imm of integer_operation * int
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
@@ -75,14 +78,23 @@ and instruction_desc =
   | Icatch of int * instruction * instruction
   | Iexit of int
   | Itrywith of instruction * instruction
-  | Iraise of Lambda.raise_kind
+  | Iraise of Cmm.raise_kind
+
+type spacetime_part_of_shape =
+  | Direct_call_point of { callee : string; }
+  | Indirect_call_point
+  | Allocation_point
+
+type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list
 
 type fundecl =
   { fun_name: string;
     fun_args: Reg.t array;
     fun_body: instruction;
     fun_fast: bool;
-    fun_dbg : Debuginfo.t }
+    fun_dbg : Debuginfo.t;
+    fun_spacetime_shape : spacetime_shape option;
+  }
 
 let rec dummy_instr =
   { desc = Iend;
@@ -114,10 +126,10 @@ let rec instr_iter f i =
       f i;
       match i.desc with
         Iend -> ()
-      | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> ()
-      | Iifthenelse(tst, ifso, ifnot) ->
+      | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) -> ()
+      | Iifthenelse(_tst, ifso, ifnot) ->
           instr_iter f ifso; instr_iter f ifnot; instr_iter f i.next
-      | Iswitch(index, cases) ->
+      | Iswitch(_index, cases) ->
           for i = 0 to Array.length cases - 1 do
             instr_iter f cases.(i)
           done;
@@ -132,3 +144,36 @@ let rec instr_iter f i =
       | Iraise _ -> ()
       | _ ->
           instr_iter f i.next
+
+let spacetime_node_hole_pointer_is_live_before insn =
+  match insn.desc with
+  | Iop op ->
+    begin match op with
+    | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _ -> true
+    | Iextcall { alloc; } -> alloc
+    | Ialloc _ ->
+      (* Allocations are special: the call to [caml_call_gc] requires some
+         instrumentation code immediately prior, but this is not inserted until
+         the emitter (since the call is not visible prior to that in any IR).
+         As such, none of the Mach / Linearize analyses will ever see that
+         we use the node hole pointer for these, and we do not need to say
+         that it is live at such points. *)
+      false
+    | Iintop op | Iintop_imm (op, _) ->
+      begin match op with
+      | Icheckbound _
+        (* [Icheckbound] doesn't need to return [true] for the same reason as
+           [Ialloc]. *)
+      | Iadd | Isub | Imul | Imulh | Idiv | Imod
+      | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
+      | Icomp _ -> false
+      end
+    | Ispecific specific_op ->
+      Arch.spacetime_node_hole_pointer_is_live_before specific_op
+    | Imove | Ispill | Ireload | Iconst_int _ | Iconst_float _
+    | Iconst_symbol _ | Istackoffset _ | Iload _ | Istore _
+    | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
+    | Ifloatofint | Iintoffloat -> false
+    end
+  | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Iloop _ | Icatch _
+  | Iexit _ | Itrywith _ | Iraise _ -> false

diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index d3d912d23300f0b95a6cbaea226e0e768706ae47..798e314f7fa9726610cc9e2c4b7ee88beb0e15a0 100644 (file)
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -15,6 +15,12 @@
 
 (* Representation of machine code by sequences of pseudoinstructions *)
 
+(** N.B. Backends vary in their treatment of call gc and checkbound
+    points.  If the positioning of any labels associated with these is
+    important for some new feature in the compiler, the relevant backends'
+    behaviour should be checked. *)
+type label = Cmm.label
+
 type integer_comparison =
     Isigned of Cmm.comparison
   | Iunsigned of Cmm.comparison
@@ -23,7 +29,11 @@ type integer_operation =
     Iadd | Isub | Imul | Imulh | Idiv | Imod
   | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr
   | Icomp of integer_comparison
-  | Icheckbound
+  | Icheckbound of { label_after_error : label option;
+        spacetime_index : int; }
+    (** For Spacetime only, [Icheckbound] operations take two arguments, the
+        second being the pointer to the trie node for the current function
+        (and the first being as per non-Spacetime mode). *)
 
 type test =
     Itruetest
@@ -41,17 +51,19 @@ type operation =
   | Iconst_int of nativeint
   | Iconst_float of int64
   | Iconst_symbol of string
-  | Iconst_blockheader of nativeint
-  | Icall_ind
-  | Icall_imm of string
-  | Itailcall_ind
-  | Itailcall_imm of string
-  | Iextcall of string * bool    (* false = noalloc, true = alloc *)
+  | Icall_ind of { label_after : label; }
+  | Icall_imm of { func : string; label_after : label; }
+  | Itailcall_ind of { label_after : label; }
+  | Itailcall_imm of { func : string; label_after : label; }
+  | Iextcall of { func : string; alloc : bool; label_after : label; }
   | Istackoffset of int
   | Iload of Cmm.memory_chunk * Arch.addressing_mode
   | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool
                                  (* false = initialization, true = assignment *)
-  | Ialloc of int
+  | Ialloc of { words : int; label_after_call_gc : label option;
+      spacetime_index : int; }
+    (** For Spacetime only, Ialloc instructions take one argument, being the
+        pointer to the trie node for the current function. *)
   | Iintop of integer_operation
   | Iintop_imm of integer_operation * int
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
@@ -76,14 +88,29 @@ and instruction_desc =
   | Icatch of int * instruction * instruction
   | Iexit of int
   | Itrywith of instruction * instruction
-  | Iraise of Lambda.raise_kind
+  | Iraise of Cmm.raise_kind
+
+type spacetime_part_of_shape =
+  | Direct_call_point of { callee : string; (* the symbol *) }
+  | Indirect_call_point
+  | Allocation_point
+
+(** A description of the layout of a Spacetime profiling node associated with
+    a given function.  Each call and allocation point instrumented within
+    the function is marked with a label in the code and assigned a place
+    within the node.  This information is stored within the executable and
+    extracted when the user saves a profile.  The aim is to minimise runtime
+    memory usage within the nodes and increase performance. *)
+type spacetime_shape = (spacetime_part_of_shape * Cmm.label) list
 
 type fundecl =
   { fun_name: string;
     fun_args: Reg.t array;
     fun_body: instruction;
     fun_fast: bool;
-    fun_dbg : Debuginfo.t }
+    fun_dbg : Debuginfo.t;
+    fun_spacetime_shape : spacetime_shape option;
+  }
 
 val dummy_instr: instruction
 val end_instr: unit -> instruction
@@ -94,3 +121,5 @@ val instr_cons_debug:
       instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t ->
         instruction -> instruction
 val instr_iter: (instruction -> unit) -> instruction -> unit
+
+val spacetime_node_hole_pointer_is_live_before : instruction -> bool

diff --git a/asmcomp/power/CSE.ml b/asmcomp/power/CSE.ml
index 3106bdd8049184a44323f222c1f59886a2e68502..b8454ffdbc6ce595eb4c9032970e80c28e8bce24 100644 (file)
--- a/asmcomp/power/CSE.ml
+++ b/asmcomp/power/CSE.ml
@@ -19,7 +19,7 @@ open Arch
 open Mach
 open CSEgen
 
-class cse = object (self)
+class cse = object
 
 inherit cse_generic as super
 
@@ -31,7 +31,7 @@ method! class_of_operation op =
 
 method! is_cheap_operation op =
   match op with
-  | Iconst_int n | Iconst_blockheader n -> n <= 32767n && n >= -32768n
+  | Iconst_int n -> n <= 32767n && n >= -32768n
   | _ -> false
 
 end

diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml
index 2e7d19caf2d73dafac21613ee6598f80439aef36..289f33ca36806cc227f284681b6f0d260b5f0b6e 100644 (file)
--- a/asmcomp/power/arch.ml
+++ b/asmcomp/power/arch.ml
@@ -46,7 +46,15 @@ let command_line_options = [
 type specific_operation =
     Imultaddf                           (* multiply and add *)
   | Imultsubf                           (* multiply and subtract *)
-  | Ialloc_far of int                   (* allocation in large functions *)
+  | Ialloc_far of                       (* allocation in large functions *)
+      { words : int; label_after_call_gc : int (*Cmm.label*) option; }
+
+(* note: we avoid introducing a dependency to Cmm since this dep
+   is not detected when "make depend" is run under amd64 *)
+
+let spacetime_node_hole_pointer_is_live_before = function
+  | Imultaddf | Imultsubf -> false
+  | Ialloc_far _ -> true
 
 (* Addressing modes *)
 
@@ -85,8 +93,8 @@ let offset_addressing addr delta =
   | Iindexed2 -> assert false
 
 let num_args_addressing = function
-    Ibased(s, n) -> 0
-  | Iindexed n -> 1
+    Ibased _ -> 0
+  | Iindexed _ -> 1
   | Iindexed2 -> 2
 
 (* Printing operations and addressing modes *)
@@ -110,5 +118,5 @@ let print_specific_operation printreg op ppf arg =
   | Imultsubf ->
       fprintf ppf "%a *f %a -f %a"
         printreg arg.(0) printreg arg.(1) printreg arg.(2)
-  | Ialloc_far n ->
-      fprintf ppf "alloc_far %d" n
+  | Ialloc_far { words; _ } ->
+      fprintf ppf "alloc_far %d" words

diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index c9b26e85c0d281a843903a14429ddd8c12ea587c..d8bc1bf0e71eae1831cc9386c0c0f43ad3161723 100644 (file)
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -1,3 +1,4 @@
+#2 "asmcomp/power/emit.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -82,9 +83,6 @@ let label_prefix = ".L"
 let emit_label lbl =
   emit_string label_prefix; emit_int lbl
 
-let emit_data_label lbl =
-  emit_string label_prefix; emit_string "d"; emit_int lbl
-
 (* Section switching *)
 
 let code_space =
@@ -116,7 +114,6 @@ let datag = if ppc64 then ".quad" else ".long"
 let mullg = if ppc64 then "mulld" else "mullw"
 let divg = if ppc64 then "divd" else "divw"
 let tglle = if ppc64 then "tdlle" else "twlle"
-let slgi = if ppc64 then "sldi" else "slwi"
 
 (* Output a processor register *)
 
@@ -303,8 +300,12 @@ let adjust_stack_offset delta =
 
 (* Record live pointers at call points *)
 
-let record_frame live dbg =
-  let lbl = new_label() in
+let record_frame ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -320,6 +321,7 @@ let record_frame live dbg =
     { fd_lbl = lbl;
       fd_frame_size = frame_size();
       fd_live_offset = !live_offset;
+      fd_raise = raise_;
       fd_debuginfo = dbg } :: !frame_descriptors;
   `{emit_label lbl}:\n`
 
@@ -422,17 +424,17 @@ module BR = Branch_relaxation.Make (struct
 
   let size =
     match abi with
-    | ELF32 -> (fun a b c -> a)
-    | ELF64v1 -> (fun a b c -> b)
-    | ELF64v2 -> (fun a b c -> c)
+    | ELF32 -> (fun a _ _ -> a)
+    | ELF64v1 -> (fun _ b _ -> b)
+    | ELF64v2 -> (fun _ _ c -> c)
 
   let tocload_size() =
     if !big_toc || !Clflags.for_package <> None then 2 else 1
 
   let load_store_size = function
-    | Ibased(s, d) ->
+    | Ibased(_s, d) ->
         if abi = ELF32 then 2 else begin
-          let (lo, hi) = low_high_s d in
+          let (_lo, hi) = low_high_s d in
           tocload_size() + (if hi = 0 then 1 else 2)
         end
     | Iindexed ofs -> if is_immediate ofs then 1 else 3
@@ -441,63 +443,65 @@ module BR = Branch_relaxation.Make (struct
   let instr_size = function
     | Lend -> 0
     | Lop(Imove | Ispill | Ireload) -> 1
-    | Lop(Iconst_int n | Iconst_blockheader n) ->
+    | Lop(Iconst_int n) ->
       if is_native_immediate n then 1
-      else if (let (lo, hi) = native_low_high_s n in
+      else if (let (_lo, hi) = native_low_high_s n in
                hi >= -0x8000 && hi <= 0x7FFF) then 2
-      else if (let (lo, hi) = native_low_high_u n in
+      else if (let (_lo, hi) = native_low_high_u n in
                hi >= -0x8000 && hi <= 0x7FFF) then 2
       else tocload_size()
-    | Lop(Iconst_float s) -> if abi = ELF32 then 2 else tocload_size()
-    | Lop(Iconst_symbol s) -> if abi = ELF32 then 2 else tocload_size()
-    | Lop(Icall_ind) -> size 2 5 4
-    | Lop(Icall_imm s) -> size 1 3 3
-    | Lop(Itailcall_ind) -> size 5 7 6
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name
+    | Lop(Iconst_float _) -> if abi = ELF32 then 2 else tocload_size()
+    | Lop(Iconst_symbol _) -> if abi = ELF32 then 2 else tocload_size()
+    | Lop(Icall_ind _) -> size 2 5 4
+    | Lop(Icall_imm _) -> size 1 3 3
+    | Lop(Itailcall_ind _) -> size 5 7 6
+    | Lop(Itailcall_imm { func; _ }) ->
+        if func = !function_name
         then 1
         else size 4 (7 + tocload_size()) (6 + tocload_size())
-    | Lop(Iextcall(s, true)) -> size 3 (2 + tocload_size()) (2 + tocload_size())
-    | Lop(Iextcall(s, false)) -> size 1 2 2
-    | Lop(Istackoffset n) -> 1
+    | Lop(Iextcall { alloc = true; _ }) ->
+      size 3 (2 + tocload_size()) (2 + tocload_size())
+    | Lop(Iextcall { alloc = false; _}) -> size 1 2 2
+    | Lop(Istackoffset _) -> 1
     | Lop(Iload(chunk, addr)) ->
       if chunk = Byte_signed
       then load_store_size addr + 1
       else load_store_size addr
-    | Lop(Istore(chunk, addr, _)) -> load_store_size addr
-    | Lop(Ialloc n) -> 4
-    | Lop(Ispecific(Ialloc_far n)) -> 5
+    | Lop(Istore(_chunk, addr, _)) -> load_store_size addr
+    | Lop(Ialloc _) -> 4
+    | Lop(Ispecific(Ialloc_far _)) -> 5
     | Lop(Iintop Imod) -> 3
-    | Lop(Iintop(Icomp cmp)) -> 4
-    | Lop(Iintop op) -> 1
-    | Lop(Iintop_imm(Icomp cmp, n)) -> 4
-    | Lop(Iintop_imm(op, n)) -> 1
+    | Lop(Iintop(Icomp _)) -> 4
+    | Lop(Iintop _) -> 1
+    | Lop(Iintop_imm(Icomp _, _)) -> 4
+    | Lop(Iintop_imm _) -> 1
     | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1
     | Lop(Ifloatofint) -> 9
     | Lop(Iintoffloat) -> 4
-    | Lop(Ispecific sop) -> 1
+    | Lop(Ispecific _) -> 1
     | Lreloadretaddr -> 2
     | Lreturn -> 2
-    | Llabel lbl -> 0
-    | Lbranch lbl -> 1
-    | Lcondbranch(tst, lbl) -> 2
+    | Llabel _ -> 0
+    | Lbranch _ -> 1
+    | Lcondbranch _ -> 2
     | Lcondbranch3(lbl0, lbl1, lbl2) ->
       1 + (if lbl0 = None then 0 else 1)
         + (if lbl1 = None then 0 else 1)
         + (if lbl2 = None then 0 else 1)
-    | Lswitch jumptbl -> size 7 (5 + tocload_size()) (5 + tocload_size())
-    | Lsetuptrap lbl -> size 1 2 2
+    | Lswitch _ -> size 7 (5 + tocload_size()) (5 + tocload_size())
+    | Lsetuptrap _ -> size 1 2 2
     | Lpushtrap -> size 4 5 5
     | Lpoptrap -> 2
     | Lraise _ -> 6
 
-  let relax_allocation ~num_words = Lop (Ispecific (Ialloc_far num_words))
+  let relax_allocation ~num_words:words ~label_after_call_gc =
+    Lop (Ispecific (Ialloc_far { words; label_after_call_gc; }))
 
   (* [classify_addr], above, never identifies these instructions as needing
      relaxing.  As such, these functions should never be called. *)
   let relax_specific_op _ = assert false
-  let relax_intop_checkbound () = assert false
-  let relax_intop_imm_checkbound ~bound:_ = assert false
+  let relax_intop_checkbound ~label_after_error:_ = assert false
+  let relax_intop_imm_checkbound ~bound:_ ~label_after_error:_ = assert false
 end)
 
 (* Output the assembly code for an instruction *)
@@ -510,22 +514,22 @@ let emit_instr i =
         let src = i.arg.(0) and dst = i.res.(0) in
         if src.loc <> dst.loc then begin
            match (src, dst) with
-           |  {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} ->
+           |  {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
                 `      mr      {emit_reg dst}, {emit_reg src}\n`
-            | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
+            | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
                 `      fmr     {emit_reg dst}, {emit_reg src}\n`
-            | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} ->
+            | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
                 `      {emit_string stg}       {emit_reg src}, {emit_stack dst}\n`
-            | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
+            | {loc = Reg _; typ = Float}, {loc = Stack _} ->
                 `      stfd    {emit_reg src}, {emit_stack dst}\n`
-            | {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} ->
+            | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
                 `      {emit_string lg}        {emit_reg dst}, {emit_stack src}\n`
-            | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
+            | {loc = Stack _; typ = Float}, {loc = Reg _} ->
                 `      lfd     {emit_reg dst}, {emit_stack src}\n`
             | (_, _) ->
                 fatal_error "Emit: Imove"
         end
-    | Lop(Iconst_int n | Iconst_blockheader n) ->
+    | Lop(Iconst_int n) ->
         if is_native_immediate n then
           `    li      {emit_reg i.res.(0)}, {emit_nativeint n}\n`
         else begin
@@ -574,31 +578,31 @@ let emit_instr i =
         | ELF64v1 | ELF64v2 ->
           emit_tocload emit_reg i.res.(0) (TocSym s)
         end
-    | Lop(Icall_ind) ->
+    | Lop(Icall_ind { label_after; }) ->
         begin match abi with
         | ELF32 ->
           `    mtctr   {emit_reg i.arg.(0)}\n`;
           `    bctrl\n`;
-          record_frame i.live i.dbg
+          record_frame i.live false i.dbg ~label:label_after
         | ELF64v1 ->
           `    ld      0, 0({emit_reg i.arg.(0)})\n`;  (* code pointer *)
           `    mtctr   0\n`;
           `    ld      2, 8({emit_reg i.arg.(0)})\n`;  (* TOC for callee *)
           `    bctrl\n`;
-          record_frame i.live i.dbg;
+          record_frame i.live false i.dbg ~label:label_after;
           emit_reload_toc()
         | ELF64v2 ->
           `    mtctr   {emit_reg i.arg.(0)}\n`;
           `    mr      12, {emit_reg i.arg.(0)}\n`;  (* addr of fn in r12 *)
           `    bctrl\n`;
-          record_frame i.live i.dbg;
+          record_frame i.live false i.dbg ~label:label_after;
           emit_reload_toc()
         end
-    | Lop(Icall_imm s) ->
+    | Lop(Icall_imm { func; label_after; }) ->
         begin match abi with
         | ELF32 ->
-            emit_call s;
-            record_frame i.live i.dbg
+            emit_call func;
+            record_frame i.live false i.dbg ~label:label_after
         | ELF64v1 | ELF64v2 ->
         (* For PPC64, we cannot just emit a "bl s; nop" sequence, because
            of the following scenario:
@@ -617,12 +621,12 @@ let emit_instr i =
                 by the linker, but this is harmless.
                 Cost: 3 instructions if same TOC, 7 if different TOC.
            Let's try option 2. *)
-            emit_call s;
-            record_frame i.live i.dbg;
+            emit_call func;
+            record_frame i.live false i.dbg ~label:label_after;
             `  nop\n`;
             emit_reload_toc()
         end
-    | Lop(Itailcall_ind) ->
+    | Lop(Itailcall_ind { label_after = _; }) ->
         begin match abi with
         | ELF32 ->
           `    mtctr   {emit_reg i.arg.(0)}\n`
@@ -640,20 +644,20 @@ let emit_instr i =
         end;
         emit_free_frame();
         `      bctr\n`
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name then
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then
           `    b       {emit_label !tailrec_entry_point}\n`
         else begin
           begin match abi with
           | ELF32 ->
             ()
           | ELF64v1 ->
-            emit_tocload emit_gpr 11 (TocSym s);
+            emit_tocload emit_gpr 11 (TocSym func);
             `  ld      0, 0(11)\n`;  (* code pointer *)
             `  mtctr   0\n`;
             `  ld      2, 8(11)\n`   (* TOC for callee *)
           | ELF64v2 ->
-            emit_tocload emit_gpr 12 (TocSym s); (* addr of fn must be in r12 *)
+            emit_tocload emit_gpr 12 (TocSym func); (* addr of fn must be in r12 *)
             `  mtctr   12\n`
           end;
           if !contains_calls then begin
@@ -663,26 +667,26 @@ let emit_instr i =
           emit_free_frame();
           begin match abi with
           | ELF32 ->
-            `  b       {emit_symbol s}\n`
+            `  b       {emit_symbol func}\n`
           | ELF64v1 | ELF64v2 ->
             `  bctr\n`
           end
         end
-    | Lop(Iextcall(s, alloc)) ->
+    | Lop(Iextcall { func; alloc; }) ->
         if not alloc then begin
-          emit_call s;
+          emit_call func;
           emit_call_nop()
         end else begin
           match abi with
           | ELF32 ->
-            `  addis   28, 0, {emit_upper emit_symbol s}\n`;
-            `  addi    28, 28, {emit_lower emit_symbol s}\n`;
+            `  addis   28, 0, {emit_upper emit_symbol func}\n`;
+            `  addi    28, 28, {emit_lower emit_symbol func}\n`;
             emit_call "caml_c_call";
-            record_frame i.live i.dbg
+            record_frame i.live false i.dbg
           | ELF64v1 | ELF64v2 ->
-            emit_tocload emit_gpr 28 (TocSym s);
+            emit_tocload emit_gpr 28 (TocSym func);
             emit_call "caml_c_call";
-            record_frame i.live i.dbg;
+            record_frame i.live false i.dbg;
             `  nop\n`
         end
     | Lop(Istackoffset n) ->
@@ -713,23 +717,31 @@ let emit_instr i =
           | Single -> "stfs"
           | Double | Double_u -> "stfd" in
         emit_load_store storeinstr addr i.arg 1 i.arg.(0)
-    | Lop(Ialloc n) ->
-        if !call_gc_label = 0 then call_gc_label := new_label();
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
+        if !call_gc_label = 0 then begin
+          match label_after_call_gc with
+          | None -> call_gc_label := new_label ()
+          | Some label -> call_gc_label := label
+        end;
         `      addi    31, 31, {emit_int(-n)}\n`;
         `      {emit_string cmplg}     31, 30\n`;
         `      addi    {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`;
         `      bltl    {emit_label !call_gc_label}\n`;
         (* Exactly 4 instructions after the beginning of the alloc sequence *)
-        record_frame i.live Debuginfo.none
-    | Lop(Ispecific(Ialloc_far n)) ->
-        if !call_gc_label = 0 then call_gc_label := new_label();
+        record_frame i.live false Debuginfo.none
+    | Lop(Ispecific(Ialloc_far { words = n; label_after_call_gc; })) ->
+        if !call_gc_label = 0 then begin
+          match label_after_call_gc with
+          | None -> call_gc_label := new_label ()
+          | Some label -> call_gc_label := label
+        end;
         let lbl = new_label() in
         `      addi    31, 31, {emit_int(-n)}\n`;
         `      {emit_string cmplg}     31, 30\n`;
         `      bge     {emit_label lbl}\n`;
         `      bl      {emit_label !call_gc_label}\n`;
         (* Exactly 4 instructions after the beginning of the alloc sequence *)
-        record_frame i.live Debuginfo.none;
+        record_frame i.live false Debuginfo.none;
         `{emit_label lbl}:     addi    {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`
     | Lop(Iintop Isub) ->               (* subfc has swapped arguments *)
         `      subfc   {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
@@ -746,9 +758,9 @@ let emit_instr i =
             `  {emit_string cmplg}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
             emit_set_comp c i.res.(0)
         end
-    | Lop(Iintop Icheckbound) ->
+    | Lop(Iintop (Icheckbound { label_after_error; })) ->
         if !Clflags.debug then
-          record_frame Reg.Set.empty i.dbg;
+          record_frame Reg.Set.empty false i.dbg ?label:label_after_error;
         `      {emit_string tglle}   {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
     | Lop(Iintop op) ->
         let instr = name_for_intop op in
@@ -764,9 +776,9 @@ let emit_instr i =
             `  {emit_string cmplg}i    {emit_reg i.arg.(0)}, {emit_int n}\n`;
             emit_set_comp c i.res.(0)
         end
-    | Lop(Iintop_imm(Icheckbound, n)) ->
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
         if !Clflags.debug then
-          record_frame Reg.Set.empty i.dbg;
+          record_frame Reg.Set.empty false i.dbg ?label:label_after_error;
         `      {emit_string tglle}i   {emit_reg i.arg.(0)}, {emit_int n}\n`
     | Lop(Iintop_imm(op, n)) ->
         let instr = name_for_intop_imm op in
@@ -931,17 +943,12 @@ let emit_instr i =
         `      addi    1, 1, {emit_int trap_size}\n`;
         adjust_stack_offset (-trap_size)
     | Lraise k ->
-        begin match !Clflags.debug, k with
-        | true, Lambda.Raise_regular ->
+        begin match k with
+        | Cmm.Raise_withtrace ->
             emit_call "caml_raise_exn";
-            record_frame Reg.Set.empty i.dbg;
-            emit_call_nop()
-        | true, Lambda.Raise_reraise ->
-            emit_call "caml_reraise_exn";
-            record_frame Reg.Set.empty i.dbg;
+            record_frame Reg.Set.empty true i.dbg;
             emit_call_nop()
-        | false, _
-        | true, Lambda.Raise_notrace ->
+        | Cmm.Raise_notrace ->
             `  {emit_string lg}        0, {emit_int trap_handler_offset}(29)\n`;
             `  mr      1, 29\n`;
             `  mtctr   0\n`;
@@ -1099,8 +1106,6 @@ let emit_item = function
       declare_global_data s
   | Cdefine_symbol s ->
       `{emit_symbol s}:\n`;
-  | Cdefine_label lbl ->
-      `{emit_data_label lbl}:\n`
   | Cint8 n ->
       `        .byte   {emit_int n}\n`
   | Cint16 n ->
@@ -1117,8 +1122,6 @@ let emit_item = function
       else emit_float64_split_directive ".long" (Int64.bits_of_float f)
   | Csymbol_address s ->
       `        {emit_string datag}     {emit_symbol s}\n`
-  | Clabel_address lbl ->
-      `        {emit_string datag}     {emit_data_label lbl}\n`
   | Cstring s ->
       emit_bytes_directive "   .byte   " s
   | Cskip n ->
@@ -1202,7 +1205,10 @@ let end_assembly() =
   declare_global_data lbl;
   `{emit_symbol lbl}:\n`;
   emit_frames
-    { efa_label = (fun l -> `  {emit_string datag}     {emit_label l}\n`);
+    { efa_code_label =
+         (fun l -> `   {emit_string datag}     {emit_label l}\n`);
+      efa_data_label =
+         (fun l -> `   {emit_string datag}     {emit_label l}\n`);
       efa_16 = (fun n -> `     .short  {emit_int n}\n`);
       efa_32 = (fun n -> `     .long   {emit_int32 n}\n`);
       efa_word = (fun n -> `   {emit_string datag}     {emit_int n}\n`);

diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml
index feb66a2678b23fd6fa0224da8acfd6929f8e1372..670e84959841ec44ff5b0d6292b3fa5a7b9a5adb 100644 (file)
--- a/asmcomp/power/proc.ml
+++ b/asmcomp/power/proc.ml
@@ -90,6 +90,8 @@ let phys_reg n =
 let stack_slot slot ty =
   Reg.at_location ty (Stack slot)
 
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
 (* Calling conventions *)
 
 let calling_conventions
@@ -167,7 +169,7 @@ let calling_conventions
 
 let incoming ofs = Incoming ofs
 let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
 
 let single_regs arg = Array.map (fun arg -> [| arg |]) arg
 let ensure_single_regs res =
@@ -184,12 +186,12 @@ let loc_arguments arg =
   in
   (ensure_single_regs loc, ofs)
 let loc_parameters arg =
-  let (loc, ofs) =
+  let (loc, _ofs) =
     calling_conventions 0 7 100 112 incoming 0 false (single_regs arg)
   in
   ensure_single_regs loc
 let loc_results res =
-  let (loc, ofs) =
+  let (loc, _ofs) =
     calling_conventions 0 7 100 112 not_supported 0 false (single_regs res)
   in
   ensure_single_regs loc
@@ -243,12 +245,10 @@ let loc_external_arguments =
       then (loc, ofs)
       else (loc, 0)
 
-let extcall_use_push = false
-
 (* Results are in GPR 3 and FPR 1 *)
 
 let loc_external_results res =
-  let (loc, ofs) =
+  let (loc, _ofs) =
     calling_conventions 0 1 100 100 not_supported 0 false (single_regs res)
   in
   ensure_single_regs loc
@@ -259,7 +259,7 @@ let loc_exn_bucket = phys_reg 0
 
 (* Volatile registers: none *)
 
-let regs_are_volatile rs = false
+let regs_are_volatile _rs = false
 
 (* Registers destroyed by operations *)
 
@@ -269,8 +269,9 @@ let destroyed_at_c_call =
      100; 101; 102; 103; 104; 105; 106; 107; 108; 109; 110; 111; 112])
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call
   | _ -> [||]
 
 let destroyed_at_raise = all_phys_regs
@@ -278,20 +279,20 @@ let destroyed_at_raise = all_phys_regs
 (* Maximal register pressure *)
 
 let safe_register_pressure = function
-    Iextcall(_, _) -> 15
+    Iextcall _ -> 15
   | _ -> 23
 
 let max_register_pressure = function
-    Iextcall(_, _) -> [| 15; 18 |]
+    Iextcall _ -> [| 15; 18 |]
   | _ -> [| 23; 30 |]
 
 (* Pure operations (without any side effect besides updating their result
    registers). *)
 
 let op_is_pure = function
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
   | Ispecific(Imultaddf | Imultsubf) -> true
   | Ispecific _ -> false
   | _ -> true

diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml
index 14f2ed81dcd28c4c275286f6812a5da0ab1c3c3e..dcbfca79f06b36b21aeac72ae8ab677c65bb2f23 100644 (file)
--- a/asmcomp/power/scheduling.ml
+++ b/asmcomp/power/scheduling.ml
@@ -38,7 +38,7 @@ method oper_latency = function
   | Ispecific(Imultaddf | Imultsubf) -> 5
   | _ -> 1
 
-method reload_retaddr_latency = 12
+method! reload_retaddr_latency = 12
   (* If we can have that many cycles between the reloadretaddr and the
      return, we can expect that the blr branch will be completely folded. *)
 
@@ -56,7 +56,7 @@ method oper_issue_cycles = function
   | Iintoffloat -> 4
   | _ -> 1
 
-method reload_retaddr_issue_cycles = 3
+method! reload_retaddr_issue_cycles = 3
   (* load then stalling mtlr *)
 
 end

diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml
index c7ef00c515e548b7e594344a281b08ed59a9418e..71c474906ebf5240705bb46f63414fd734ff222a 100644 (file)
--- a/asmcomp/power/selection.ml
+++ b/asmcomp/power/selection.ml
@@ -51,7 +51,7 @@ inherit Selectgen.selector_generic as super
 
 method is_immediate n = (n <= 32767) && (n >= -32768)
 
-method select_addressing chunk exp =
+method select_addressing _chunk exp =
   match select_addr exp with
     (Asymbol s, d) ->
       (Ibased(s, d), Ctuple [])

diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml
index ba0c646267853b8abc5fcc349314ee848963e3dc..c4a790a2aab5f550bbe8e280732cb9e2db0a8b4a 100644 (file)
--- a/asmcomp/printclambda.ml
+++ b/asmcomp/printclambda.ml
@@ -18,6 +18,20 @@ open Format
 open Asttypes
 open Clambda
 
+let mutable_flag = function
+  | Mutable-> "[mut]"
+  | Immutable -> ""
+
+let value_kind =
+  let open Lambda in
+  function
+  | Pgenval -> ""
+  | Pintval -> ":int"
+  | Pfloatval -> ":float"
+  | Pboxedintval Pnativeint -> ":nativeint"
+  | Pboxedintval Pint32 -> ":int32"
+  | Pboxedintval Pint64 -> ":int64"
+
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x
   | Uconst_int32 x -> fprintf ppf "%ldl" x
@@ -78,13 +92,15 @@ and lam ppf = function
         List.iter (fprintf ppf "@ %a" lam) in
       fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
   | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
-  | Ulet(id, arg, body) ->
+  | Ulet(mut, kind, id, arg, body) ->
       let rec letbody ul = match ul with
-        | Ulet(id, arg, body) ->
-            fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
+        | Ulet(mut, kind, id, arg, body) ->
+            fprintf ppf "@ @[<2>%a%s%s@ %a@]"
+              Ident.print id (mutable_flag mut) (value_kind kind) lam arg;
             letbody body
         | _ -> ul in
-      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a%s%s@ %a@]"
+        Ident.print id (mutable_flag mut) (value_kind kind) lam arg;
       let expr = letbody body in
       fprintf ppf ")@]@ %a)@]" lam expr
   | Uletrec(id_arg_list, body) ->

diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index b97f53705d1e74fe2e20f5339b642913356e8192..21823e312ce8e0e2f974525d9b79a651c406e5ec 100644 (file)
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -53,12 +53,16 @@ let chunk = function
   | Double -> "float64"
   | Double_u -> "float64u"
 
+let raise_kind fmt = function
+  | Raise_withtrace -> Format.fprintf fmt "raise_withtrace"
+  | Raise_notrace -> Format.fprintf fmt "raise_notrace"
+
 let operation = function
-  | Capply(ty, d) -> "app" ^ Debuginfo.to_string d
-  | Cextcall(lbl, ty, alloc, d) ->
+  | Capply(_ty, d) -> "app" ^ Debuginfo.to_string d
+  | Cextcall(lbl, _ty, _alloc, d, _) ->
       Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d)
   | Cload c -> Printf.sprintf "load %s" (chunk c)
-  | Calloc -> "alloc"
+  | Calloc d -> "alloc" ^ Debuginfo.to_string d
   | Cstore (c, init) ->
     let init =
       match init with
@@ -91,13 +95,16 @@ let operation = function
   | Cfloatofint -> "floatofint"
   | Cintoffloat -> "intoffloat"
   | Ccmpf c -> Printf.sprintf "%sf" (comparison c)
-  | Craise (k, d) -> Lambda.raise_kind k ^ Debuginfo.to_string d
+  | Craise (k, d) -> Format.asprintf "%a%s" raise_kind k (Debuginfo.to_string d)
   | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d
 
 let rec expr ppf = function
   | Cconst_int n -> fprintf ppf "%i" n
-  | Cconst_natint n | Cconst_blockheader n ->
+  | Cconst_natint n ->
     fprintf ppf "%s" (Nativeint.to_string n)
+  | Cblockheader(n, d) ->
+    fprintf ppf "block-hdr(%s)%s"
+      (Nativeint.to_string n) (Debuginfo.to_string d)
   | Cconst_float n -> fprintf ppf "%F" n
   | Cconst_symbol s -> fprintf ppf "\"%s\"" s
   | Cconst_pointer n -> fprintf ppf "%ia" n
@@ -134,7 +141,7 @@ let rec expr ppf = function
       List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
       begin match op with
       | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty
-      | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty
+      | Cextcall(_, mty, _, _, _) -> fprintf ppf "@ %a" machtype mty
       | _ -> ()
       end;
       fprintf ppf ")@]"
@@ -191,7 +198,6 @@ let fundecl ppf f =
 
 let data_item ppf = function
   | Cdefine_symbol s -> fprintf ppf "\"%s\":" s
-  | Cdefine_label l -> fprintf ppf "L%i:" l
   | Cglobal_symbol s -> fprintf ppf "global \"%s\"" s
   | Cint8 n -> fprintf ppf "byte %i" n
   | Cint16 n -> fprintf ppf "int16 %i" n
@@ -200,7 +206,6 @@ let data_item ppf = function
   | Csingle f -> fprintf ppf "single %F" f
   | Cdouble f -> fprintf ppf "double %F" f
   | Csymbol_address s -> fprintf ppf "addr \"%s\"" s
-  | Clabel_address l -> fprintf ppf "addr L%i" l
   | Cstring s -> fprintf ppf "string \"%s\"" s
   | Cskip n -> fprintf ppf "skip %i" n
   | Calign n -> fprintf ppf "align %i" n

diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli
index 31145e65e15fd2d84a3cd165e912722d1bf0d4e5..86ec11fe6826daaa5a49a5d790b70859036c4198 100644 (file)
--- a/asmcomp/printcmm.mli
+++ b/asmcomp/printcmm.mli
@@ -26,3 +26,4 @@ val expression : formatter -> Cmm.expression -> unit
 val fundecl : formatter -> Cmm.fundecl -> unit
 val data : formatter -> Cmm.data_item list -> unit
 val phrase : formatter -> Cmm.phrase -> unit
+val raise_kind: formatter -> Cmm.raise_kind -> unit

diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml
index fb3d397ba1940ea5fe3bd51d4ecaf376b273c747..faf26d2df3ae44c65a018044e193181a169f96e1 100644 (file)
--- a/asmcomp/printlinear.ml
+++ b/asmcomp/printlinear.ml
@@ -28,7 +28,7 @@ let instr ppf i =
   | Lend -> ()
   | Lop op ->
       begin match op with
-      | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall(_, _) ->
+      | Ialloc _ | Icall_ind _ | Icall_imm _ | Iextcall _ ->
           fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live
       | _ -> ()
       end;
@@ -64,7 +64,7 @@ let instr ppf i =
   | Lpoptrap ->
       fprintf ppf "pop trap"
   | Lraise k ->
-      fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0)
+      fprintf ppf "%a %a" Printcmm.raise_kind k reg i.arg.(0)
   end;
   if not (Debuginfo.is_none i.dbg) then
     fprintf ppf " %s" (Debuginfo.to_string i.dbg)

diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index 82b95a8b49e92f06d783756a8dbd752f64f89c14..e9e4937d7a441c5550e322e57e779920e34ec809 100644 (file)
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -87,7 +87,16 @@ let intop = function
   | Ilsr -> " >>u "
   | Iasr -> " >>s "
   | Icomp cmp -> intcomp cmp
-  | Icheckbound -> " check > "
+  | Icheckbound { label_after_error; spacetime_index; } ->
+    if not Config.spacetime then " check > "
+    else
+      Printf.sprintf "check[lbl=%s,index=%d] > "
+        begin
+          match label_after_error with
+          | None -> ""
+          | Some lbl -> string_of_int lbl
+        end
+        spacetime_index
 
 let test tst ppf arg =
   match tst with
@@ -110,16 +119,15 @@ let operation op arg ppf res =
   | Imove -> regs ppf arg
   | Ispill -> fprintf ppf "%a (spill)" regs arg
   | Ireload -> fprintf ppf "%a (reload)" regs arg
-  | Iconst_int n
-  | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n)
+  | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n)
   | Iconst_float f -> fprintf ppf "%F" (Int64.float_of_bits f)
   | Iconst_symbol s -> fprintf ppf "\"%s\"" s
-  | Icall_ind -> fprintf ppf "call %a" regs arg
-  | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg
-  | Itailcall_ind -> fprintf ppf "tailcall %a" regs arg
-  | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg
-  | Iextcall(lbl, alloc) ->
-      fprintf ppf "extcall \"%s\" %a%s" lbl regs arg
+  | Icall_ind _ -> fprintf ppf "call %a" regs arg
+  | Icall_imm { func; _ } -> fprintf ppf "call \"%s\" %a" func regs arg
+  | Itailcall_ind _ -> fprintf ppf "tailcall %a" regs arg
+  | Itailcall_imm { func; } -> fprintf ppf "tailcall \"%s\" %a" func regs arg
+  | Iextcall { func; alloc; _ } ->
+      fprintf ppf "extcall \"%s\" %a%s" func regs arg
       (if alloc then "" else " (noalloc)")
   | Istackoffset n ->
       fprintf ppf "offset stack %i" n
@@ -133,7 +141,11 @@ let operation op arg ppf res =
        (Array.sub arg 1 (Array.length arg - 1))
        reg arg.(0)
        (if is_assign then "(assign)" else "(init)")
-  | Ialloc n -> fprintf ppf "alloc %i" n
+  | Ialloc { words = n; _ } ->
+    fprintf ppf "alloc %i" n;
+    if Config.spacetime then begin
+      fprintf ppf "(spacetime node = %a)" reg arg.(0)
+    end
   | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1)
   | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n
   | Inegf -> fprintf ppf "-f %a" reg arg.(0)
@@ -188,7 +200,7 @@ let rec instr ppf i =
       fprintf ppf "@[<v 2>try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]"
              instr body instr handler
   | Iraise k ->
-      fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0)
+      fprintf ppf "%a %a" Printcmm.raise_kind k reg i.arg.(0)
   end;
   if not (Debuginfo.is_none i.dbg) then
     fprintf ppf "%s" (Debuginfo.to_string i.dbg);

diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli
index 060099985cdb632003c705e89a44bcda141dfcdd..23f503fa893a16b9252524f704d7d6d53200fd3d 100644 (file)
--- a/asmcomp/proc.mli
+++ b/asmcomp/proc.mli
@@ -39,6 +39,7 @@ val loc_parameters: Reg.t array -> Reg.t array
 val loc_external_arguments: Reg.t array array -> Reg.t array array * int
 val loc_external_results: Reg.t array -> Reg.t array
 val loc_exn_bucket: Reg.t
+val loc_spacetime_node_hole: Reg.t
 
 (* The maximum number of arguments of an OCaml to OCaml function call for
    which it is guaranteed there will be no arguments passed on the stack.

diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml
index 09c68b7e64d596ecc9aa967d0f4bb61281bc445e..f40cf02daa30b1d15c1a953dba1e22fadbd873b3 100644 (file)
--- a/asmcomp/reloadgen.ml
+++ b/asmcomp/reloadgen.ml
@@ -73,7 +73,7 @@ method reload_operation op arg res =
   | _ ->
       (self#makeregs arg, self#makeregs res)
 
-method reload_test tst args =
+method reload_test _tst args =
   self#makeregs args
 
 method private reload i =
@@ -83,13 +83,13 @@ method private reload i =
        However, something needs to be done for the function pointer in
        indirect calls. *)
     Iend | Ireturn | Iop(Itailcall_imm _) | Iraise _ -> i
-  | Iop(Itailcall_ind) ->
+  | Iop(Itailcall_ind _) ->
       let newarg = self#makereg1 i.arg in
       insert_moves i.arg newarg
         {i with arg = newarg}
   | Iop(Icall_imm _ | Iextcall _) ->
       {i with next = self#reload i.next}
-  | Iop(Icall_ind) ->
+  | Iop(Icall_ind _) ->
       let newarg = self#makereg1 i.arg in
       insert_moves i.arg newarg
         {i with arg = newarg; next = self#reload i.next}
@@ -127,7 +127,6 @@ method fundecl f =
   let new_body = self#reload f.fun_body in
   ({fun_name = f.fun_name; fun_args = f.fun_args;
     fun_body = new_body; fun_fast = f.fun_fast;
-    fun_dbg  = f.fun_dbg},
+    fun_dbg  = f.fun_dbg; fun_spacetime_shape = f.fun_spacetime_shape},
    redo_regalloc)
-
 end

diff --git a/asmcomp/s390x/CSE.ml b/asmcomp/s390x/CSE.ml
index e5805f244e806c6aea28055e890ad6e28190fe65..360a4f137204fa91d4ac9be047e29941b5817922 100644 (file)
--- a/asmcomp/s390x/CSE.ml
+++ b/asmcomp/s390x/CSE.ml
@@ -21,7 +21,7 @@ open Arch
 open Mach
 open CSEgen
 
-class cse = object (self)
+class cse = object
 
 inherit cse_generic as super
 
@@ -32,7 +32,7 @@ method! class_of_operation op =
 
 method! is_cheap_operation op =
   match op with
-  | Iconst_int n | Iconst_blockheader n ->
+  | Iconst_int n ->
       n >= -0x8000_0000n && n <= 0x7FFF_FFFFn
   | _ -> false
 

diff --git a/asmcomp/s390x/arch.ml b/asmcomp/s390x/arch.ml
index 954beb93238c39574ba508f48017c232c4c10a91..84d52d644c92822f5c36082d296b0b9c06965ba7 100644 (file)
--- a/asmcomp/s390x/arch.ml
+++ b/asmcomp/s390x/arch.ml
@@ -35,6 +35,8 @@ type specific_operation =
     Imultaddf                           (* multiply and add *)
   | Imultsubf                           (* multiply and subtract *)
 
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
 (* Addressing modes *)
 
 type addressing_mode =
@@ -65,8 +67,8 @@ let offset_addressing addr delta =
   | Iindexed2 n -> Iindexed2(n + delta)
 
 let num_args_addressing = function
-  | Iindexed n -> 1
-  | Iindexed2 n -> 2
+  | Iindexed _ -> 1
+  | Iindexed2 _ -> 2
 
 (* Printing operations and addressing modes *)
 

diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp
index 8226464bf3906ae46a1632a55f83508963b53a1d..5d233a3655df128dfce82c413ccefee3488fa4db 100644 (file)
--- a/asmcomp/s390x/emit.mlp
+++ b/asmcomp/s390x/emit.mlp
@@ -1,3 +1,4 @@
+#2 "asmcomp/s390x/emit.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -15,9 +16,6 @@
 
 (* Emission of Linux on Z 64-bit assembly code *)
 
-module StringSet =
-  Set.Make(struct type t = string let compare (x:t) y = compare x y end)
-
 open Misc
 open Cmm
 open Arch
@@ -67,9 +65,6 @@ let label_prefix = ".L"
 let emit_label lbl =
   emit_string label_prefix; emit_int lbl
 
-let emit_data_label lbl =
-  emit_string label_prefix; emit_string "d"; emit_int lbl
-
 (* Section switching *)
 
 let data_space = "     .section \".data\"\n"
@@ -86,10 +81,6 @@ let emit_reg r =
   | _ -> fatal_error "Emit.emit_reg"
 
 
-let emit_gpr r = emit_string "%r"; emit_int r
-
-let emit_fpr r = emit_string "%f"; emit_int r
-
 (* Special registers *)
 
 let reg_f15 = phys_reg 115
@@ -157,8 +148,12 @@ let emit_set_comp cmp res =
 
 (* Record live pointers at call points *)
 
-let record_frame live dbg =
-  let lbl = new_label() in
+let record_frame ?label live raise_ dbg =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -174,6 +169,7 @@ let record_frame live dbg =
     { fd_lbl = lbl;
       fd_frame_size = frame_size();
       fd_live_offset = !live_offset;
+      fd_raise = raise_;
       fd_debuginfo = dbg } :: !frame_descriptors;
   lbl
 
@@ -199,10 +195,10 @@ type bound_error_call =
 let bound_error_sites = ref ([] : bound_error_call list)
 let bound_error_call = ref 0
 
-let bound_error_label dbg =
+let bound_error_label ?label dbg =
   if !Clflags.debug then begin
     let lbl_bound_error = new_label() in
-    let lbl_frame = record_frame Reg.Set.empty dbg in
+    let lbl_frame = record_frame ?label Reg.Set.empty false dbg in
     bound_error_sites :=
      { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites;
    lbl_bound_error
@@ -292,22 +288,22 @@ let emit_instr i =
         let src = i.arg.(0) and dst = i.res.(0) in
         if src.loc <> dst.loc then begin
            match (src, dst) with
-              {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} ->
+              {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
                 `      lgr     {emit_reg dst}, {emit_reg src}\n`
-            | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
+            | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
                 `      ldr     {emit_reg dst}, {emit_reg src}\n`
-            | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} ->
+            | {loc = Reg _; typ = (Val | Int | Addr)}, {loc = Stack _} ->
                 `      stg     {emit_reg src}, {emit_stack dst}\n`
-            | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
+            | {loc = Reg _; typ = Float}, {loc = Stack _} ->
                 `      std     {emit_reg src}, {emit_stack dst}\n`
-            | {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} ->
+            | {loc = Stack _; typ = (Val | Int | Addr)}, {loc = Reg _} ->
                 `      lg      {emit_reg dst}, {emit_stack src}\n`
-            | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
+            | {loc = Stack _; typ = Float}, {loc = Reg _} ->
                 `      ldy     {emit_reg dst}, {emit_stack src}\n`
             | (_, _) ->
                 fatal_error "Emit: Imove"
         end
-    | Lop(Iconst_int n | Iconst_blockheader n) ->
+    | Lop(Iconst_int n) ->
         if n >= -0x8000n && n <= 0x7FFFn then begin
           `    lghi    {emit_reg i.res.(0)}, {emit_nativeint n}\n`;
         end else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin
@@ -327,26 +323,26 @@ let emit_instr i =
         `      lgrl    {emit_reg i.res.(0)}, {emit_symbol s}@GOTENT\n`
         else
         `      larl    {emit_reg i.res.(0)}, {emit_symbol s}\n`;
-    | Lop(Icall_ind) ->
+    | Lop(Icall_ind { label_after; }) ->
         `      basr    %r14, {emit_reg i.arg.(0)}\n`;
-        let lbl = record_frame i.live i.dbg in
+        let lbl = record_frame i.live false i.dbg ~label:label_after in
          `{emit_label lbl}:\n`
 
-    | Lop(Icall_imm s) ->
+    | Lop(Icall_imm { func; label_after; }) ->
         if !pic_code then
-        `      brasl   %r14, {emit_symbol s}@PLT\n`
+        `      brasl   %r14, {emit_symbol func}@PLT\n`
         else
-        `      brasl   %r14, {emit_symbol s}\n`;
-        let lbl = record_frame i.live i.dbg in
+        `      brasl   %r14, {emit_symbol func}\n`;
+        let lbl = record_frame i.live false i.dbg ~label:label_after in
          `{emit_label lbl}:\n`;
-    | Lop(Itailcall_ind) ->
+    | Lop(Itailcall_ind { label_after = _; }) ->
         let n = frame_size() in
         if !contains_calls then
           `    lg      %r14, {emit_int(n - size_addr)}(%r15)\n`;
         emit_stack_adjust (-n);
         `      br      {emit_reg i.arg.(0)}\n`
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name then
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
+        if func = !function_name then
           `    brcl    15, {emit_label !tailrec_entry_point}\n`
         else begin
           let n = frame_size() in
@@ -354,27 +350,27 @@ let emit_instr i =
             `  lg      %r14, {emit_int(n - size_addr)}(%r15)\n`;
           emit_stack_adjust (-n);
           if !pic_code then
-            `  brcl    15, {emit_symbol s}@PLT\n`
+            `  brcl    15, {emit_symbol func}@PLT\n`
           else
-            `  brcl    15, {emit_symbol s}\n`
+            `  brcl    15, {emit_symbol func}\n`
         end
 
-     | Lop(Iextcall(s, alloc)) ->
+     | Lop(Iextcall { func; alloc; label_after; }) ->
         if alloc then begin
           if !pic_code then begin
-          `    lgrl    %r7, {emit_symbol s}@GOTENT\n`;
+          `    lgrl    %r7, {emit_symbol func}@GOTENT\n`;
           `    brasl   %r14, {emit_symbol "caml_c_call"}@PLT\n`
           end else begin
-          `    larl    %r7, {emit_symbol s}\n`;
+          `    larl    %r7, {emit_symbol func}\n`;
           `    brasl   %r14, {emit_symbol "caml_c_call"}\n`
           end;
-          let lbl = record_frame i.live i.dbg in
+          let lbl = record_frame i.live false i.dbg ~label:label_after in
            `{emit_label lbl}:\n`;
         end else begin
           if !pic_code then
-          `    brasl   %r14, {emit_symbol s}@PLT\n`
+          `    brasl   %r14, {emit_symbol func}@PLT\n`
           else
-          `    brasl   %r14, {emit_symbol s}\n`
+          `    brasl   %r14, {emit_symbol func}\n`
        end
 
      | Lop(Istackoffset n) ->
@@ -411,10 +407,12 @@ let emit_instr i =
           | Double | Double_u -> "stdy" in
         emit_load_store storeinstr addr i.arg 1 i.arg.(0)
 
-    | Lop(Ialloc n) ->
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
         let lbl_redo = new_label() in
         let lbl_call_gc = new_label() in
-        let lbl_frame = record_frame i.live i.dbg in
+        let lbl_frame =
+          record_frame i.live false i.dbg ?label:label_after_call_gc
+        in
         call_gc_sites :=
           { gc_lbl = lbl_call_gc;
             gc_return_lbl = lbl_redo;
@@ -467,8 +465,8 @@ let emit_instr i =
         `      brc     {emit_int mask}, {emit_label lbl}\n`;
         `      lghi    {emit_reg i.res.(0)}, 0\n`;
         `{emit_label lbl}:\n`
-    | Lop(Iintop Icheckbound) ->
-        let lbl = bound_error_label i.dbg in
+    | Lop(Iintop (Icheckbound { label_after_error; })) ->
+        let lbl = bound_error_label i.dbg ?label:label_after_error in
         `      clgr    {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         `      brcl    12, {emit_label lbl}\n`  (* branch if unsigned le *)
     | Lop(Iintop op) ->
@@ -487,8 +485,8 @@ let emit_instr i =
         `      brc     {emit_int mask}, {emit_label lbl}\n`;
         `      lghi    {emit_reg i.res.(0)}, 0\n`;
         `{emit_label lbl}:\n`
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-       let lbl = bound_error_label i.dbg in
+    | Lop(Iintop_imm(Icheckbound { label_after_error; }, n)) ->
+       let lbl = bound_error_label i.dbg ?label:label_after_error in
        if n >= 0 then begin
         `      clgfi   {emit_reg i.arg.(0)}, {emit_int n}\n`;
         `      brcl    12, {emit_label lbl}\n`  (* branch if unsigned le *)
@@ -503,7 +501,7 @@ let emit_instr i =
         `      srag    {emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n`
     | Lop(Iintop_imm(Iand, n)) ->
         assert (i.arg.(0).loc = i.res.(0).loc);
-        `      nilf    {emit_reg i.res.(0)}, {emit_int (n land 0xFFFF_FFFF)}\n`
+        `      nilf    {emit_reg i.res.(0)}, {emit_int (n land (1 lsl 32 - 1)(*0xFFFF_FFFF*))}\n`
     | Lop(Iintop_imm(Ior, n)) ->
         assert (i.arg.(0).loc = i.res.(0).loc);
         `      oilf    {emit_reg i.res.(0)}, {emit_int n}\n`
@@ -611,17 +609,12 @@ let emit_instr i =
         emit_stack_adjust (-16);
         stack_offset := !stack_offset - 16
     | Lraise k ->
-        begin match !Clflags.debug, k with
-        | true, Lambda.Raise_regular ->
+        begin match k with
+        | Cmm.Raise_withtrace ->
           `    brasl   %r14, {emit_symbol "caml_raise_exn"}\n`;
-          let lbl = record_frame Reg.Set.empty i.dbg in
-          `{emit_label lbl}:\n`
-        | true, Lambda.Raise_reraise ->
-          `    brasl   %r14, {emit_symbol "caml_reraise_exn"}\n`;
-          let lbl = record_frame Reg.Set.empty i.dbg in
+          let lbl = record_frame Reg.Set.empty true i.dbg in
           `{emit_label lbl}:\n`
-        | false, _
-        | true, Lambda.Raise_notrace ->
+        | Cmm.Raise_notrace ->
           `    lg      %r1, 0(%r13)\n`;
           `    lgr     %r15, %r13\n`;
           `    lg      %r13, {emit_int size_addr}(%r15)\n`;
@@ -692,8 +685,6 @@ let emit_item = function
       declare_global_data s
   | Cdefine_symbol s ->
       `{emit_symbol s}:\n`;
-  | Cdefine_label lbl ->
-      `{emit_data_label lbl}:\n`
   | Cint8 n ->
       `        .byte   {emit_int n}\n`
   | Cint16 n ->
@@ -708,8 +699,6 @@ let emit_item = function
       emit_float64_directive ".quad" (Int64.bits_of_float f)
   | Csymbol_address s ->
       `        .quad   {emit_symbol s}\n`
-  | Clabel_address lbl ->
-      `        .quad   {emit_data_label lbl}\n`
   | Cstring s ->
       emit_bytes_directive "   .byte   " s
   | Cskip n ->
@@ -759,7 +748,8 @@ let end_assembly() =
   declare_global_data lbl;
   `{emit_symbol lbl}:\n`;
   emit_frames
-    { efa_label = (fun l -> `  .quad   {emit_label l}\n`);
+    { efa_code_label = (fun l -> `     .quad   {emit_label l}\n`);
+      efa_data_label = (fun l -> `     .quad   {emit_label l}\n`);
       efa_16 = (fun n -> `     .short  {emit_int n}\n`);
       efa_32 = (fun n -> `     .long   {emit_int32 n}\n`);
       efa_word = (fun n -> `   .quad   {emit_int n}\n`);

diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml
index dd162966014e1c3d57fa1d1116de79890d589b16..a8bd2cbf74d533523b5dbf8a709bcc431cce4a3b 100644 (file)
--- a/asmcomp/s390x/proc.ml
+++ b/asmcomp/s390x/proc.ml
@@ -94,6 +94,8 @@ let phys_reg n =
 let stack_slot slot ty =
   Reg.at_location ty (Stack slot)
 
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
 (* Calling conventions *)
 
 let calling_conventions
@@ -126,16 +128,16 @@ let calling_conventions
 
 let incoming ofs = Incoming ofs
 let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
 
 let max_arguments_for_tailcalls = 5
 
 let loc_arguments arg =
   calling_conventions 0 4 100 103 outgoing 0 arg
 let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc
+  let (loc, _ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc
 let loc_results res =
-  let (loc, ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc
+  let (loc, _ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc
 
 (*   C calling conventions under SVR4:
      use GPR 2-6 and FPR 0,2,4,6 just like ML calling conventions.
@@ -150,12 +152,10 @@ let loc_external_arguments arg =
     calling_conventions 0 4 100 103 outgoing 160 arg in
   (Array.map (fun reg -> [|reg|]) loc, ofs)
 
-let extcall_use_push = false
-
 (* Results are in GPR 2 and FPR 0 *)
 
 let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc
+  let (loc, _ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc
 
 (* Exceptions are in GPR 2 *)
 
@@ -163,7 +163,7 @@ let loc_exn_bucket = phys_reg 0
 
 (* Volatile registers: none *)
 
-let regs_are_volatile rs = false
+let regs_are_volatile _rs = false
 
 (* Registers destroyed by operations *)
 
@@ -173,8 +173,9 @@ let destroyed_at_c_call =
      100; 101; 102; 103; 104; 105; 106; 107])
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; _ }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; _ }) -> destroyed_at_c_call
   | _ -> [||]
 
 let destroyed_at_raise = all_phys_regs
@@ -182,20 +183,20 @@ let destroyed_at_raise = all_phys_regs
 (* Maximal register pressure *)
 
 let safe_register_pressure = function
-    Iextcall(_, _) -> 4
+    Iextcall _ -> 4
   | _ -> 9
 
 let max_register_pressure = function
-    Iextcall(_, _) -> [| 4; 7 |]
+    Iextcall _ -> [| 4; 7 |]
   | _ -> [| 9; 15 |]
 
 (* Pure operations (without any side effect besides updating their result
    registers). *)
 
 let op_is_pure = function
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
   | Ispecific(Imultaddf | Imultsubf) -> true
   | _ -> true
 

diff --git a/asmcomp/s390x/scheduling.ml b/asmcomp/s390x/scheduling.ml
index 6ac11d352a7b1763b5b27fe615ad1c01e7cae27e..a766d6a34f1732d4eb58171627592532df22f864 100644 (file)
--- a/asmcomp/s390x/scheduling.ml
+++ b/asmcomp/s390x/scheduling.ml
@@ -44,7 +44,7 @@ method oper_latency = function
   | Ispecific(Imultaddf | Imultsubf) -> 8
   | _ -> 2
 
-method reload_retaddr_latency = 4
+method! reload_retaddr_latency = 4
 
 (* Issue cycles.  Rough approximations. *)
 
@@ -56,7 +56,7 @@ method oper_issue_cycles = function
   | Iintop_imm(Icomp _, _) -> 4
   | _ -> 1
 
-method reload_retaddr_issue_cycles = 1
+method! reload_retaddr_issue_cycles = 1
 
 end
 

diff --git a/asmcomp/s390x/selection.ml b/asmcomp/s390x/selection.ml
index 4c0df5f033aae39d9ee507c50d1ad6503aabd0bb..9a00108d0979514675bbff581d2bd911e1d25e4d 100644 (file)
--- a/asmcomp/s390x/selection.ml
+++ b/asmcomp/s390x/selection.ml
@@ -51,7 +51,7 @@ let pseudoregs_for_operation op arg res =
   (* Two-address binary operations: arg.(0) and res.(0) must be the same *)
   | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor)  | Iaddf|Isubf|Imulf|Idivf ->
       ([|res.(0); arg.(1)|], res)
-  | Ispecific(sop) ->
+  | Ispecific _ ->
     ( [| arg.(0); arg.(1); res.(0) |], [| res.(0) |])
   (* One-address unary operations: arg.(0) and res.(0) must be the same *)
   |  Iintop_imm((Imul|Iand|Ior|Ixor), _) -> (res, res)
@@ -62,9 +62,11 @@ class selector = object (self)
 
 inherit Selectgen.selector_generic as super
 
-method is_immediate n = (n <= 2147483647) && (n >= -2147483648)
+method is_immediate n = n <= 0x7FFF_FFFF && n >= (-1-0x7FFF_FFFF)
+  (* -1-.... : hack so that this can be compiled on 32-bit
+     (cf 'make check_all_arches') *)
 
-method select_addressing chunk exp =
+method select_addressing _chunk exp =
   let (a, d) = select_addr exp in
   (* 20-bit signed displacement *)
   if d < 0x80000 && d >= -0x80000 then begin
@@ -80,9 +82,10 @@ method! select_operation op args =
     (Cmulhi, _) -> (Iintop Imulh, args)
   (* The and, or and xor instructions have a different range of immediate
      operands than the other instructions *)
-  | (Cand, _) -> self#select_logical Iand (-0x1_0000_0000) (-1) args
-  | (Cor, _) -> self#select_logical Ior 0 0xFFFF_FFFF args
-  | (Cxor, _) -> self#select_logical Ixor  0 0xFFFF_FFFF args
+  | (Cand, _) ->
+      self#select_logical Iand (-1 lsl 32 (*0x1_0000_0000*)) (-1) args
+  | (Cor, _) -> self#select_logical Ior 0 (1 lsl 32 - 1 (*0xFFFF_FFFF*)) args
+  | (Cxor, _) -> self#select_logical Ixor  0 (1 lsl 32 - 1 (*0xFFFF_FFFF*)) args
   (* Recognize mult-add and mult-sub instructions *)
   | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
       (Ispecific Imultaddf, [arg1; arg2; arg3])

diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml
index e228d1c3c167e600905c34ad006703475c370623..440fe2f0f80cf1f546d9dec8e935b02e5bdb960f 100644 (file)
--- a/asmcomp/schedgen.ml
+++ b/asmcomp/schedgen.ml
@@ -148,9 +148,9 @@ val mutable trywith_nesting = 0
    that terminate a basic block. *)
 
 method oper_in_basic_block = function
-    Icall_ind -> false
+    Icall_ind _ -> false
   | Icall_imm _ -> false
-  | Itailcall_ind -> false
+  | Itailcall_ind _ -> false
   | Itailcall_imm _ -> false
   | Iextcall _ -> false
   | Istackoffset _ -> false
@@ -185,8 +185,8 @@ method is_load = function
   | _ -> false
 
 method is_checkbound = function
-    Iintop Icheckbound -> true
-  | Iintop_imm(Icheckbound, _) -> true
+    Iintop (Icheckbound _) -> true
+  | Iintop_imm(Icheckbound _, _) -> true
   | _ -> false
 
 method private instr_is_store instr =
@@ -375,7 +375,7 @@ method schedule_fundecl f =
     else begin
       let critical_outputs =
         match i.desc with
-          Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |]
+          Lop(Icall_ind _ | Itailcall_ind _) -> [| i.arg.(0) |]
         | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||]
         | Lreturn -> [||]
         | _ -> i.arg in
@@ -389,7 +389,9 @@ method schedule_fundecl f =
     { fun_name = f.fun_name;
       fun_body = new_body;
       fun_fast = f.fun_fast;
-      fun_dbg  = f.fun_dbg }
+      fun_dbg  = f.fun_dbg;
+      fun_spacetime_shape = f.fun_spacetime_shape;
+    }
   end else
     f
 

diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 257327a74979c5e1b7a642cc20a1f5384f8e44fe..f7e1c0d872bc4fba218044c16ed85a05c7b2d079 100644 (file)
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -27,15 +27,15 @@ type environment = (Ident.t, Reg.t array) Tbl.t
 
 let oper_result_type = function
     Capply(ty, _) -> ty
-  | Cextcall(s, ty, alloc, _) -> ty
+  | Cextcall(_s, ty, _alloc, _, _) -> ty
   | Cload c ->
       begin match c with
       | Word_val -> typ_val
       | Single | Double | Double_u -> typ_float
       | _ -> typ_int
       end
-  | Calloc -> typ_val
-  | Cstore (c, _) -> typ_void
+  | Calloc _ -> typ_val
+  | Cstore (_c, _) -> typ_void
   | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi |
     Cand | Cor | Cxor | Clsl | Clsr | Casr |
     Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int
@@ -51,11 +51,11 @@ let oper_result_type = function
 
 let size_expr env exp =
   let rec size localenv = function
-      Cconst_int _ | Cconst_natint _
-    | Cconst_blockheader _ -> Arch.size_int
+      Cconst_int _ | Cconst_natint _ -> Arch.size_int
     | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ ->
         Arch.size_addr
     | Cconst_float _ -> Arch.size_float
+    | Cblockheader _ -> Arch.size_int
     | Cvar id ->
         begin try
           Tbl.find id localenv
@@ -69,11 +69,11 @@ let size_expr env exp =
         end
     | Ctuple el ->
         List.fold_right (fun e sz -> size localenv e + sz) el 0
-    | Cop(op, args) ->
+    | Cop(op, _) ->
         size_machtype(oper_result_type op)
     | Clet(id, arg, body) ->
         size (Tbl.add id (size localenv arg) localenv) body
-    | Csequence(e1, e2) ->
+    | Csequence(_e1, e2) ->
         size localenv e2
     | _ ->
         fatal_error "Selection.size_expr"
@@ -141,16 +141,25 @@ let join opt_r1 seq1 opt_r2 seq2 =
 let join_array rs =
   let some_res = ref None in
   for i = 0 to Array.length rs - 1 do
-    let (r, s) = rs.(i) in
-    if r <> None then some_res := r
+    let (r, _) = rs.(i) in
+    match r with
+    | None -> ()
+    | Some r ->
+      match !some_res with
+      | None -> some_res := Some (r, Array.map (fun r -> r.typ) r)
+      | Some (r', types) ->
+        let types =
+          Array.map2 (fun r typ -> Cmm.lub_component r.typ typ) r types
+        in
+        some_res := Some (r', types)
   done;
   match !some_res with
     None -> None
-  | Some template ->
+  | Some (template, types) ->
       let size_res = Array.length template in
       let res = Array.make size_res Reg.dummy in
       for i = 0 to size_res - 1 do
-        res.(i) <- Reg.create template.(i).typ
+        res.(i) <- Reg.create types.(i)
       done;
       for i = 0 to Array.length rs - 1 do
         let (r, s) = rs.(i) in
@@ -163,9 +172,10 @@ let join_array rs =
 (* Extract debug info contained in a C-- operation *)
 let debuginfo_op = function
   | Capply(_, dbg) -> dbg
-  | Cextcall(_, _, _, dbg) -> dbg
+  | Cextcall(_, _, _, dbg, _) -> dbg
   | Craise (_, dbg) -> dbg
   | Ccheckbound dbg -> dbg
+  | Calloc dbg -> dbg
   | _ -> Debuginfo.none
 
 (* Registers for catch constructs *)
@@ -188,19 +198,19 @@ class virtual selector_generic = object (self)
 method is_simple_expr = function
     Cconst_int _ -> true
   | Cconst_natint _ -> true
-  | Cconst_blockheader _ -> true
   | Cconst_float _ -> true
   | Cconst_symbol _ -> true
   | Cconst_pointer _ -> true
   | Cconst_natpointer _ -> true
+  | Cblockheader _ -> true
   | Cvar _ -> true
   | Ctuple el -> List.for_all self#is_simple_expr el
-  | Clet(id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body
+  | Clet(_id, arg, body) -> self#is_simple_expr arg && self#is_simple_expr body
   | Csequence(e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2
   | Cop(op, args) ->
       begin match op with
         (* The following may have side effects *)
-      | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ -> false
+      | Capply _ | Cextcall _ | Calloc _ | Cstore _ | Craise _ -> false
         (* The remaining operations are simple if their args are *)
       | _ ->
           List.for_all self#is_simple_expr args
@@ -231,21 +241,21 @@ method mark_tailcall = ()
 method mark_c_tailcall = ()
 
 method mark_instr = function
-  | Iop (Icall_ind | Icall_imm _ | Iextcall _) ->
+  | Iop (Icall_ind _ | Icall_imm _ | Iextcall _) ->
       self#mark_call
-  | Iop (Itailcall_ind | Itailcall_imm _) ->
+  | Iop (Itailcall_ind _ | Itailcall_imm _) ->
       self#mark_tailcall
   | Iop (Ialloc _) ->
       self#mark_call (* caml_alloc*, caml_garbage_collection *)
-  | Iop (Iintop Icheckbound | Iintop_imm(Icheckbound, _)) ->
+  | Iop (Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _)) ->
       self#mark_c_tailcall (* caml_ml_array_bound_error *)
   | Iraise raise_kind ->
     begin match raise_kind with
-      | Lambda.Raise_notrace -> ()
-      | Lambda.Raise_regular | Lambda.Raise_reraise ->
-        if !Clflags.debug then (* PR#6239 *)
-        (* caml_stash_backtrace; we #mark_call rather than
-           #mark_c_tailcall to get a good stack backtrace *)
+      | Cmm.Raise_notrace -> ()
+      | Cmm.Raise_withtrace ->
+          (* PR#6239 *)
+          (* caml_stash_backtrace; we #mark_call rather than
+             #mark_c_tailcall to get a good stack backtrace *)
           self#mark_call
     end
   | Itrywith _ ->
@@ -254,11 +264,29 @@ method mark_instr = function
 
 (* Default instruction selection for operators *)
 
+method select_allocation words =
+  Ialloc { words; spacetime_index = 0; label_after_call_gc = None; }
+method select_allocation_args _env = [| |]
+
+method select_checkbound () =
+  Icheckbound { spacetime_index = 0; label_after_error = None; }
+method select_checkbound_extra_args () = []
+
 method select_operation op args =
   match (op, args) with
-    (Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem)
-  | (Capply(ty, dbg), _) -> (Icall_ind, args)
-  | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args)
+  | (Capply _, Cconst_symbol func :: rem) ->
+    let label_after = Cmm.new_label () in
+    (Icall_imm { func; label_after; }, rem)
+  | (Capply _, _) ->
+    let label_after = Cmm.new_label () in
+    (Icall_ind { label_after; }, args)
+  | (Cextcall(func, _ty, alloc, _dbg, label_after), _) ->
+    let label_after =
+      match label_after with
+      | None -> Cmm.new_label ()
+      | Some label_after -> label_after
+    in
+    Iextcall { func; alloc; label_after; }, args
   | (Cload chunk, [arg]) ->
       let (addr, eloc) = self#select_addressing chunk arg in
       (Iload(chunk, addr), [eloc])
@@ -276,7 +304,7 @@ method select_operation op args =
         (Istore(chunk, addr, is_assign), [arg2; eloc])
         (* Inversion addr/datum in Istore *)
       end
-  | (Calloc, _) -> (Ialloc 0, args)
+  | (Calloc _dbg, _) -> (self#select_allocation 0), args
   | (Caddi, _) -> self#select_arith_comm Iadd args
   | (Csubi, _) -> self#select_arith Isub args
   | (Cmuli, _) -> self#select_arith_comm Imul args
@@ -301,7 +329,10 @@ method select_operation op args =
   | (Cdivf, _) -> (Idivf, args)
   | (Cfloatofint, _) -> (Ifloatofint, args)
   | (Cintoffloat, _) -> (Iintoffloat, args)
-  | (Ccheckbound _, _) -> self#select_arith Icheckbound args
+  | (Ccheckbound _, _) ->
+    let extra_args = self#select_checkbound_extra_args () in
+    let op = self#select_checkbound () in
+    self#select_arith op (args @ extra_args)
   | _ -> fatal_error "Selection.select_oper"
 
 method private select_arith_comm op = function
@@ -389,12 +420,15 @@ method insert_debug desc dbg arg res =
 method insert desc arg res =
   instr_seq <- instr_cons desc arg res instr_seq
 
-method extract =
+method extract_core ~end_instr =
   let rec extract res i =
     if i == dummy_instr
     then res
     else extract {i with next = res} i.next in
-  extract (end_instr()) instr_seq
+  extract end_instr instr_seq
+
+method extract =
+  self#extract_core ~end_instr:(end_instr ())
 
 (* Insert a sequence of moves from one pseudoreg set to another. *)
 
@@ -446,6 +480,20 @@ method insert_op_debug op dbg rs rd =
 method insert_op op rs rd =
   self#insert_op_debug op Debuginfo.none rs rd
 
+method emit_blockheader _env n _dbg =
+  let r = self#regs_for typ_int in
+  Some(self#insert_op (Iconst_int n) [||] r)
+
+method about_to_emit_call _env _insn _arg = None
+
+(* Prior to a function call, update the Spacetime node hole pointer hard
+   register. *)
+
+method private maybe_emit_spacetime_move ~spacetime_reg =
+  Misc.Stdlib.Option.iter (fun reg ->
+      self#insert_moves reg [| Proc.loc_spacetime_node_hole |])
+    spacetime_reg
+
 (* Add the instructions for the given expression
    at the end of the self sequence *)
 
@@ -457,9 +505,6 @@ method emit_expr env exp =
   | Cconst_natint n ->
       let r = self#regs_for typ_int in
       Some(self#insert_op (Iconst_int n) [||] r)
-  | Cconst_blockheader n ->
-      let r = self#regs_for typ_int in
-      Some(self#insert_op (Iconst_blockheader n) [||] r)
   | Cconst_float n ->
       let r = self#regs_for typ_float in
       Some(self#insert_op (Iconst_float (Int64.bits_of_float n)) [||] r)
@@ -472,6 +517,8 @@ method emit_expr env exp =
   | Cconst_natpointer n ->
       let r = self#regs_for typ_val in  (* integer as Caml value *)
       Some(self#insert_op (Iconst_int n) [||] r)
+  | Cblockheader(n, dbg) ->
+      self#emit_blockheader env n dbg
   | Cvar v ->
       begin try
         Some(Tbl.find v env)
@@ -510,7 +557,7 @@ method emit_expr env exp =
           self#insert_debug (Iraise k) dbg rd [||];
           None
       end
-  | Cop(Ccmpf comp, args) ->
+  | Cop(Ccmpf _, _) ->
       self#emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0))
   | Cop(op, args) ->
       begin match self#emit_parts_list env args with
@@ -520,37 +567,54 @@ method emit_expr env exp =
           let (new_op, new_args) = self#select_operation op simple_args in
           let dbg = debuginfo_op op in
           match new_op with
-            Icall_ind ->
+            Icall_ind _ ->
               let r1 = self#emit_tuple env new_args in
               let rarg = Array.sub r1 1 (Array.length r1 - 1) in
               let rd = self#regs_for ty in
               let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
               let loc_res = Proc.loc_results rd in
+              let spacetime_reg =
+                self#about_to_emit_call env (Iop new_op) [| r1.(0) |]
+              in
               self#insert_move_args rarg loc_arg stack_ofs;
-              self#insert_debug (Iop Icall_ind) dbg
+              self#maybe_emit_spacetime_move ~spacetime_reg;
+              self#insert_debug (Iop new_op) dbg
                           (Array.append [|r1.(0)|] loc_arg) loc_res;
               self#insert_move_results loc_res rd stack_ofs;
               Some rd
-          | Icall_imm lbl ->
+          | Icall_imm _ ->
               let r1 = self#emit_tuple env new_args in
               let rd = self#regs_for ty in
               let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
               let loc_res = Proc.loc_results rd in
+              let spacetime_reg =
+                self#about_to_emit_call env (Iop new_op) [| |]
+              in
               self#insert_move_args r1 loc_arg stack_ofs;
-              self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res;
+              self#maybe_emit_spacetime_move ~spacetime_reg;
+              self#insert_debug (Iop new_op) dbg loc_arg loc_res;
               self#insert_move_results loc_res rd stack_ofs;
               Some rd
-          | Iextcall(lbl, alloc) ->
+          | Iextcall _ ->
+              let spacetime_reg =
+                self#about_to_emit_call env (Iop new_op) [| |]
+              in
               let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in
+              self#maybe_emit_spacetime_move ~spacetime_reg;
               let rd = self#regs_for ty in
-              let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg
-                                    loc_arg (Proc.loc_external_results rd) in
+              let loc_res =
+                self#insert_op_debug new_op dbg
+                  loc_arg (Proc.loc_external_results rd) in
               self#insert_move_results loc_res rd stack_ofs;
               Some rd
-          | Ialloc _ ->
+          | Ialloc { words = _; spacetime_index; label_after_call_gc; } ->
               let rd = self#regs_for typ_val in
               let size = size_expr env (Ctuple new_args) in
-              self#insert (Iop(Ialloc size)) [||] rd;
+              let op =
+                Ialloc { words = size; spacetime_index; label_after_call_gc; }
+              in
+              let args = self#select_allocation_args env in
+              self#insert_debug (Iop op) dbg args rd;
               self#emit_stores env new_args rd;
               Some rd
           | op ->
@@ -561,7 +625,7 @@ method emit_expr env exp =
   | Csequence(e1, e2) ->
       begin match self#emit_expr env e1 with
         None -> None
-      | Some r1 -> self#emit_expr env e2
+      | Some _ -> self#emit_expr env e2
       end
   | Cifthenelse(econd, eif, eelse) ->
       let (cond, earg) = self#select_condition econd in
@@ -582,12 +646,12 @@ method emit_expr env exp =
           let rscases = Array.map (self#emit_sequence env) ecases in
           let r = join_array rscases in
           self#insert (Iswitch(index,
-                               Array.map (fun (r, s) -> s#extract) rscases))
+                               Array.map (fun (_, s) -> s#extract) rscases))
                       rsel [||];
           r
       end
   | Cloop(ebody) ->
-      let (rarg, sbody) = self#emit_sequence env ebody in
+      let (_rarg, sbody) = self#emit_sequence env ebody in
       self#insert (Iloop(sbody#extract)) [||] [||];
       Some [||]
   | Ccatch(nfail, ids, e1, e2) ->
@@ -761,38 +825,61 @@ method emit_tail env exp =
       | Some(simple_args, env) ->
           let (new_op, new_args) = self#select_operation op simple_args in
           match new_op with
-            Icall_ind ->
+            Icall_ind { label_after; } ->
               let r1 = self#emit_tuple env new_args in
               let rarg = Array.sub r1 1 (Array.length r1 - 1) in
               let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in
               if stack_ofs = 0 then begin
+                let call = Iop (Itailcall_ind { label_after; }) in
+                let spacetime_reg =
+                  self#about_to_emit_call env call [| r1.(0) |]
+                in
                 self#insert_moves rarg loc_arg;
-                self#insert (Iop Itailcall_ind)
-                            (Array.append [|r1.(0)|] loc_arg) [||]
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug call dbg
+                            (Array.append [|r1.(0)|] loc_arg) [||];
               end else begin
                 let rd = self#regs_for ty in
                 let loc_res = Proc.loc_results rd in
+                let spacetime_reg =
+                  self#about_to_emit_call env (Iop new_op) [| r1.(0) |]
+                in
                 self#insert_move_args rarg loc_arg stack_ofs;
-                self#insert_debug (Iop Icall_ind) dbg
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug (Iop new_op) dbg
                             (Array.append [|r1.(0)|] loc_arg) loc_res;
                 self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||];
                 self#insert Ireturn loc_res [||]
               end
-          | Icall_imm lbl ->
+          | Icall_imm { func; label_after; } ->
               let r1 = self#emit_tuple env new_args in
               let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
               if stack_ofs = 0 then begin
+                let call = Iop (Itailcall_imm { func; label_after; }) in
+                let spacetime_reg =
+                  self#about_to_emit_call env call [| |]
+                in
                 self#insert_moves r1 loc_arg;
-                self#insert (Iop(Itailcall_imm lbl)) loc_arg [||]
-              end else if lbl = !current_function_name then begin
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug call dbg loc_arg [||];
+              end else if func = !current_function_name then begin
+                let call = Iop (Itailcall_imm { func; label_after; }) in
                 let loc_arg' = Proc.loc_parameters r1 in
+                let spacetime_reg =
+                  self#about_to_emit_call env call [| |]
+                in
                 self#insert_moves r1 loc_arg';
-                self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||]
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug call dbg loc_arg' [||];
               end else begin
                 let rd = self#regs_for ty in
                 let loc_res = Proc.loc_results rd in
+                let spacetime_reg =
+                  self#about_to_emit_call env (Iop new_op) [| |]
+                in
                 self#insert_move_args r1 loc_arg stack_ofs;
-                self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res;
+                self#maybe_emit_spacetime_move ~spacetime_reg;
+                self#insert_debug (Iop new_op) dbg loc_arg loc_res;
                 self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||];
                 self#insert Ireturn loc_res [||]
               end
@@ -801,7 +888,7 @@ method emit_tail env exp =
   | Csequence(e1, e2) ->
       begin match self#emit_expr env e1 with
         None -> ()
-      | Some r1 -> self#emit_tail env e2
+      | Some _ -> self#emit_tail env e2
       end
   | Cifthenelse(econd, eif, eelse) ->
       let (cond, earg) = self#select_condition econd in
@@ -860,8 +947,16 @@ method private emit_tail_sequence env exp =
   s#emit_tail env exp;
   s#extract
 
+(* Insertion of the function prologue *)
+
+method insert_prologue _f ~loc_arg ~rarg ~spacetime_node_hole:_ ~env:_ =
+  self#insert_moves loc_arg rarg;
+  None
+
 (* Sequentialization of a function definition *)
 
+method initial_env () = Tbl.empty
+
 method emit_fundecl f =
   Proc.contains_calls := false;
   current_function_name := f.Cmm.fun_name;
@@ -871,19 +966,38 @@ method emit_fundecl f =
       f.Cmm.fun_args in
   let rarg = Array.concat rargs in
   let loc_arg = Proc.loc_parameters rarg in
+  (* To make it easier to add the Spacetime instrumentation code, we
+     first emit the body and extract the resulting instruction sequence;
+     then we emit the prologue followed by any Spacetime instrumentation.  The
+     sequence resulting from extracting the latter (prologue + instrumentation)
+     together is then simply prepended to the body. *)
   let env =
     List.fold_right2
-      (fun (id, ty) r env -> Tbl.add id r env)
-      f.Cmm.fun_args rargs Tbl.empty in
-  self#insert_moves loc_arg rarg;
+      (fun (id, _ty) r env -> Tbl.add id r env)
+      f.Cmm.fun_args rargs (self#initial_env ()) in
+  let spacetime_node_hole, env =
+    if not Config.spacetime then None, env
+    else begin
+      let reg = self#regs_for typ_int in
+      let node_hole = Ident.create "spacetime_node_hole" in
+      Some (node_hole, reg), Tbl.add node_hole reg env
+    end
+  in
   self#emit_tail env f.Cmm.fun_body;
   let body = self#extract in
+  instr_seq <- dummy_instr;
+  let fun_spacetime_shape =
+    self#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env
+  in
+  let body = self#extract_core ~end_instr:body in
   instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body;
   { fun_name = f.Cmm.fun_name;
     fun_args = loc_arg;
     fun_body = body;
     fun_fast = f.Cmm.fun_fast;
-    fun_dbg  = f.Cmm.fun_dbg }
+    fun_dbg  = f.Cmm.fun_dbg;
+    fun_spacetime_shape;
+  }
 
 end
 
@@ -895,7 +1009,7 @@ end
 let is_tail_call nargs =
   assert (Reg.dummy.typ = Int);
   let args = Array.make (nargs + 1) Reg.dummy in
-  let (loc_arg, stack_ofs) = Proc.loc_arguments args in
+  let (_loc_arg, stack_ofs) = Proc.loc_arguments args in
   stack_ofs = 0
 
 let _ =

diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli
index b579b07b9fe4c2d3b4437b3a40cf2772127fa914..5df80ad36b21bdb3caf80b97817d3230899b6c94 100644 (file)
--- a/asmcomp/selectgen.mli
+++ b/asmcomp/selectgen.mli
@@ -86,13 +86,15 @@ class virtual selector_generic : object
      above; overloading this is useful if Ispecific instructions need
      marking *)
 
-  (* The following method is the entry point and should not be overridden *)
+  (* The following method is the entry point and should not be overridden
+     (except by [Spacetime_profiling]). *)
   method emit_fundecl : Cmm.fundecl -> Mach.fundecl
 
   (* The following methods should not be overridden.  They cannot be
      declared "private" in the current implementation because they
      are not always applied to "self", but ideally they should be private. *)
   method extract : Mach.instruction
+  method extract_core : end_instr:Mach.instruction -> Mach.instruction
   method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit
   method insert_debug : Mach.instruction_desc -> Debuginfo.t ->
                                         Reg.t array -> Reg.t array -> unit
@@ -105,6 +107,32 @@ class virtual selector_generic : object
   method emit_expr :
     (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option
   method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit
+
+  (* Only for the use of [Spacetime_profiling]. *)
+  method select_allocation : int -> Mach.operation
+  method select_allocation_args : (Ident.t, Reg.t array) Tbl.t -> Reg.t array
+  method select_checkbound : unit -> Mach.integer_operation
+  method select_checkbound_extra_args : unit -> Cmm.expression list
+  method emit_blockheader
+     : (Ident.t, Reg.t array) Tbl.t
+    -> nativeint
+    -> Debuginfo.t
+    -> Reg.t array option
+  method about_to_emit_call
+     : (Ident.t, Reg.t array) Tbl.t
+    -> Mach.instruction_desc
+    -> Reg.t array
+    -> Reg.t array option
+  method initial_env : unit -> (Ident.t, Reg.t array) Tbl.t
+  method insert_prologue
+     : Cmm.fundecl
+    -> loc_arg:Reg.t array
+    -> rarg:Reg.t array
+    -> spacetime_node_hole:(Ident.t * Reg.t array) option
+    -> env:(Ident.t, Reg.t array) Tbl.t
+    -> Mach.spacetime_shape option
+
+  val mutable instr_seq : Mach.instruction
 end
 
 val reset : unit -> unit

diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml
new file mode 100644 (file)
index 0000000..32037c5
--- /dev/null
+++ b/asmcomp/spacetime_profiling.ml
@@ -0,0 +1,421 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+let node_num_header_words = 2 (* [Node_num_header_words] in the runtime. *)
+let index_within_node = ref node_num_header_words
+(* The [lazy]s are to ensure that we don't create [Ident.t]s at toplevel
+   when not using Spacetime profiling.  (This could cause stamps to differ
+   between bytecode and native .cmis when no .mli is present, e.g.
+   arch.ml.) *)
+let spacetime_node = ref (lazy (Cmm.Cvar (Ident.create "dummy")))
+let spacetime_node_ident = ref (lazy (Ident.create "dummy"))
+let current_function_label = ref ""
+let direct_tail_call_point_indexes = ref []
+
+let reverse_shape = ref ([] : Mach.spacetime_shape)
+
+let something_was_instrumented () =
+  !index_within_node > node_num_header_words
+
+let next_index_within_node ~part_of_shape ~label =
+  let index = !index_within_node in
+  begin match part_of_shape with
+  | Mach.Direct_call_point _ | Mach.Indirect_call_point ->
+    incr index_within_node
+  | Mach.Allocation_point ->
+    incr index_within_node;
+    incr index_within_node;
+    incr index_within_node
+  end;
+  reverse_shape := (part_of_shape, label) :: !reverse_shape;
+  index
+
+let reset ~spacetime_node_ident:ident ~function_label =
+  index_within_node := node_num_header_words;
+  spacetime_node := lazy (Cmm.Cvar ident);
+  spacetime_node_ident := lazy ident;
+  direct_tail_call_point_indexes := [];
+  current_function_label := function_label;
+  reverse_shape := []
+
+let code_for_function_prologue ~function_name ~node_hole =
+  let node = Ident.create "node" in
+  let new_node = Ident.create "new_node" in
+  let must_allocate_node = Ident.create "must_allocate_node" in
+  let is_new_node = Ident.create "is_new_node" in
+  let no_tail_calls = List.length !direct_tail_call_point_indexes < 1 in
+  let open Cmm in
+  let initialize_direct_tail_call_points_and_return_node =
+    let new_node_encoded = Ident.create "new_node_encoded" in
+    (* The callee node pointers within direct tail call points must initially
+       point back at the start of the current node and be marked as per
+       [Encode_tail_caller_node] in the runtime. *)
+    let indexes = !direct_tail_call_point_indexes in
+    let body =
+      List.fold_left (fun init_code index ->
+          (* Cf. [Direct_callee_node] in the runtime. *)
+          let offset_in_bytes = index * Arch.size_addr in
+          Csequence (
+            Cop (Cstore (Word_int, Lambda.Assignment),
+              [Cop (Caddi, [Cvar new_node; Cconst_int offset_in_bytes]);
+               Cvar new_node_encoded]),
+            init_code))
+        (Cvar new_node)
+        indexes
+    in
+    match indexes with
+    | [] -> body
+    | _ ->
+      Clet (new_node_encoded,
+        (* Cf. [Encode_tail_caller_node] in the runtime. *)
+        Cop (Cor, [Cvar new_node; Cconst_int 1]),
+        body)
+  in
+  let pc = Ident.create "pc" in
+  Clet (node, Cop (Cload Word_int, [Cvar node_hole]),
+    Clet (must_allocate_node, Cop (Cand, [Cvar node; Cconst_int 1]),
+      Cifthenelse (Cop (Ccmpi Cne, [Cvar must_allocate_node; Cconst_int 1]),
+        Cvar node,
+        Clet (is_new_node,
+          Clet (pc, Cconst_symbol function_name,
+            Cop (Cextcall ("caml_spacetime_allocate_node",
+              [| Int |], false, Debuginfo.none, None),
+              [Cconst_int (1 (* header *) + !index_within_node);
+               Cvar pc;
+               Cvar node_hole;
+              ])),
+            Clet (new_node, Cop (Cload Word_int, [Cvar node_hole]),
+              if no_tail_calls then Cvar new_node
+              else
+                Cifthenelse (
+                  Cop (Ccmpi Ceq, [Cvar is_new_node; Cconst_int 0]),
+                  Cvar new_node,
+                  initialize_direct_tail_call_points_and_return_node))))))
+
+let code_for_blockheader ~value's_header ~node ~dbg =
+  let num_words = Nativeint.shift_right_logical value's_header 10 in
+  let existing_profinfo = Ident.create "existing_profinfo" in
+  let existing_count = Ident.create "existing_count" in
+  let profinfo = Ident.create "profinfo" in
+  let address_of_profinfo = Ident.create "address_of_profinfo" in
+  let label = Cmm.new_label () in
+  let index_within_node =
+    next_index_within_node ~part_of_shape:Mach.Allocation_point ~label
+  in
+  let offset_into_node = Arch.size_addr * index_within_node in
+  let open Cmm in
+  let generate_new_profinfo =
+    (* This will generate a static branch to a function that should usually
+       be in the cache, which hopefully gives a good code size/performance
+       balance.
+       The "Some label" is important: it provides the link between the shape
+       table, the allocation point, and the frame descriptor table---enabling
+       the latter table to be used for resolving a program counter at such
+       a point to a location.
+    *)
+    Cop (Cextcall ("caml_spacetime_generate_profinfo", [| Int |],
+        false, dbg, Some label),
+      [Cvar address_of_profinfo;
+       Cconst_int (index_within_node + 1)])
+  in
+  (* Check if we have already allocated a profinfo value for this allocation
+     point with the current backtrace.  If so, use that value; if not,
+     allocate a new one. *)
+  Clet (address_of_profinfo,
+    Cop (Caddi, [
+      Cvar node;
+      Cconst_int offset_into_node;
+    ]),
+    Clet (existing_profinfo, Cop (Cload Word_int, [Cvar address_of_profinfo]),
+      Clet (profinfo,
+        Cifthenelse (
+          Cop (Ccmpi Cne, [Cvar existing_profinfo; Cconst_int 1 (* () *)]),
+          Cvar existing_profinfo,
+          generate_new_profinfo),
+        Clet (existing_count,
+          Cop (Cload Word_int, [
+            Cop (Caddi,
+              [Cvar address_of_profinfo; Cconst_int Arch.size_addr])
+          ]),
+          Csequence (
+            Cop (Cstore (Word_int, Lambda.Assignment),
+              [Cop (Caddi,
+                [Cvar address_of_profinfo; Cconst_int Arch.size_addr]);
+                Cop (Caddi, [
+                  Cvar existing_count;
+                  (* N.B. "*2" since the count is an OCaml integer.
+                     The "1 +" is to count the value's header. *)
+                  Cconst_int (2 * (1 + Nativeint.to_int num_words));
+                ]);
+              ]),
+            (* [profinfo] looks like a black [Infix_tag] header.  Instead of
+               having to mask [profinfo] before ORing it with the desired
+               header, we can use an XOR trick, to keep code size down. *)
+            let value's_header =
+              Nativeint.logxor value's_header
+                (Nativeint.logor
+                  ((Nativeint.logor (Nativeint.of_int Obj.infix_tag)
+                    (Nativeint.shift_left 3n (* <- Caml_black *) 8)))
+                  (Nativeint.shift_left
+                    (* The following is the [Infix_offset_val], in words. *)
+                    (Nativeint.of_int (index_within_node + 1)) 10))
+            in
+            Cop (Cxor, [Cvar profinfo; Cconst_natint value's_header]))))))
+
+type callee =
+  | Direct of string
+  | Indirect of Cmm.expression
+
+let code_for_call ~node ~callee ~is_tail ~label =
+  (* We treat self recursive calls as tail calls to avoid blow-ups in the
+     graph. *)
+  let is_self_recursive_call =
+    match callee with
+    | Direct callee -> callee = !current_function_label
+    | Indirect _ -> false
+  in
+  let is_tail = is_tail || is_self_recursive_call in
+  let index_within_node =
+    match callee with
+    | Direct callee ->
+      next_index_within_node
+        ~part_of_shape:(Mach.Direct_call_point { callee; })
+        ~label
+    | Indirect _ ->
+      next_index_within_node ~part_of_shape:Mach.Indirect_call_point ~label
+  in
+  begin match callee with
+    (* If this is a direct tail call point, we need to note down its index,
+       so the correct initialization code can be emitted in the prologue. *)
+    | Direct _ when is_tail ->
+      direct_tail_call_point_indexes :=
+        index_within_node::!direct_tail_call_point_indexes
+    | Direct _ | Indirect _ -> ()
+  end;
+  let place_within_node = Ident.create "place_within_node" in
+  let open Cmm in
+  Clet (place_within_node,
+    Cop (Caddi, [node; Cconst_int (index_within_node * Arch.size_addr)]),
+    (* The following code returns the address that is to be moved into the
+       (hard) node hole pointer register immediately before the call.
+       (That move is inserted in [Selectgen].) *)
+    match callee with
+    | Direct _callee -> Cvar place_within_node
+    | Indirect callee ->
+      let caller_node =
+        if is_tail then node
+        else Cconst_int 1  (* [Val_unit] *)
+      in
+      Cop (Cextcall ("caml_spacetime_indirect_node_hole_ptr",
+          [| Int |], false, Debuginfo.none, None),
+        [callee; Cvar place_within_node; caller_node]))
+
+class virtual instruction_selection = object (self)
+  inherit Selectgen.selector_generic as super
+
+  (* [disable_instrumentation] ensures that we don't try to instrument the
+     instrumentation... *)
+  val mutable disable_instrumentation = false
+
+  method private instrument_direct_call ~env ~func ~is_tail ~label_after =
+    let instrumentation =
+      code_for_call
+        ~node:(Lazy.force !spacetime_node)
+        ~callee:(Direct func)
+        ~is_tail
+        ~label:label_after
+    in
+    match self#emit_expr env instrumentation with
+    | None -> assert false
+    | Some reg -> Some reg
+
+  method private instrument_indirect_call ~env ~callee ~is_tail
+        ~label_after =
+    (* [callee] is a pseudoregister, so we have to bind it in the environment
+       and reference the variable to which it is bound. *)
+    let callee_ident = Ident.create "callee" in
+    let env = Tbl.add callee_ident [| callee |] env in
+    let instrumentation =
+      code_for_call
+        ~node:(Lazy.force !spacetime_node)
+        ~callee:(Indirect (Cmm.Cvar callee_ident))
+        ~is_tail
+        ~label:label_after
+    in
+    match self#emit_expr env instrumentation with
+    | None -> assert false
+    | Some reg -> Some reg
+
+  method private can_instrument () =
+    Config.spacetime && not disable_instrumentation
+
+  method! about_to_emit_call env desc arg =
+    if not (self#can_instrument ()) then None
+    else
+      let module M = Mach in
+      match desc with
+      | M.Iop (M.Icall_imm { func; label_after; }) ->
+        assert (Array.length arg = 0);
+        self#instrument_direct_call ~env ~func ~is_tail:false ~label_after
+      | M.Iop (M.Icall_ind { label_after; }) ->
+        assert (Array.length arg = 1);
+        self#instrument_indirect_call ~env ~callee:arg.(0)
+          ~is_tail:false ~label_after
+      | M.Iop (M.Itailcall_imm { func; label_after; }) ->
+        assert (Array.length arg = 0);
+        self#instrument_direct_call ~env ~func ~is_tail:true ~label_after
+      | M.Iop (M.Itailcall_ind { label_after; }) ->
+        assert (Array.length arg = 1);
+        self#instrument_indirect_call ~env ~callee:arg.(0)
+          ~is_tail:true ~label_after
+      | M.Iop (M.Iextcall { func; alloc = true; label_after; }) ->
+        (* N.B. No need to instrument "noalloc" external calls. *)
+        assert (Array.length arg = 0);
+        self#instrument_direct_call ~env ~func ~is_tail:false ~label_after
+      | _ -> None
+
+  method private instrument_blockheader ~env ~value's_header ~dbg =
+    let instrumentation =
+      code_for_blockheader
+        ~node:(Lazy.force !spacetime_node_ident)
+        ~value's_header ~dbg
+    in
+    self#emit_expr env instrumentation
+
+  method private emit_prologue f ~node_hole ~env =
+    (* We don't need the prologue unless we inserted some instrumentation.
+       This corresponds to adding the prologue if the function contains one
+       or more call or allocation points. *)
+    if something_was_instrumented () then begin
+      let prologue_cmm =
+        code_for_function_prologue ~function_name:f.Cmm.fun_name ~node_hole
+      in
+      disable_instrumentation <- true;
+      let node_temp_reg =
+        match self#emit_expr env prologue_cmm with
+        | None ->
+          Misc.fatal_error "Spacetime prologue instruction \
+              selection did not yield a destination register"
+        | Some node_temp_reg -> node_temp_reg
+      in
+      disable_instrumentation <- false;
+      let node = Lazy.force !spacetime_node_ident in
+      let node_reg = Tbl.find node env in
+      self#insert_moves node_temp_reg node_reg
+    end
+
+  method! emit_blockheader env n dbg =
+    if self#can_instrument () then begin
+      disable_instrumentation <- true;
+      let result = self#instrument_blockheader ~env ~value's_header:n ~dbg in
+      disable_instrumentation <- false;
+      result
+    end else begin
+      super#emit_blockheader env n dbg
+    end
+
+  method! select_allocation words =
+    if self#can_instrument () then begin
+      (* Leave space for a direct call point.  We cannot easily insert any
+         instrumentation code, so the fields are filled in instead by
+         [caml_spacetime_caml_garbage_collection]. *)
+      let label = Cmm.new_label () in
+      let index =
+        next_index_within_node
+          ~part_of_shape:(Mach.Direct_call_point { callee = "caml_call_gc"; })
+          ~label
+      in
+      Mach.Ialloc {
+        words;
+        label_after_call_gc = Some label;
+        spacetime_index = index;
+      }
+    end else begin
+      super#select_allocation words
+    end
+
+  method! select_allocation_args env =
+    if self#can_instrument () then begin
+      let regs = Tbl.find (Lazy.force !spacetime_node_ident) env in
+      match regs with
+      | [| reg |] -> [| reg |]
+      | _ -> failwith "Expected one register only for spacetime_node_ident"
+    end else begin
+      super#select_allocation_args env
+    end
+
+  method! select_checkbound () =
+    (* This follows [select_allocation], above. *)
+    if self#can_instrument () then begin
+      let label = Cmm.new_label () in
+      let index =
+        next_index_within_node
+          ~part_of_shape:(
+            Mach.Direct_call_point { callee = "caml_ml_array_bound_error"; })
+          ~label
+      in
+      Mach.Icheckbound {
+        label_after_error = Some label;
+        spacetime_index = index;
+      }
+    end else begin
+      super#select_checkbound ()
+    end
+
+  method! select_checkbound_extra_args () =
+    if self#can_instrument () then begin
+      (* This follows [select_allocation_args], above. *)
+      [Cmm.Cvar (Lazy.force !spacetime_node_ident)]
+    end else begin
+      super#select_checkbound_extra_args ()
+    end
+
+  method! initial_env () =
+    let env = super#initial_env () in
+    if Config.spacetime then
+      Tbl.add (Lazy.force !spacetime_node_ident)
+        (self#regs_for Cmm.typ_int) env
+    else
+      env
+
+  method! emit_fundecl f =
+    if Config.spacetime then begin
+      disable_instrumentation <- false;
+      let node = Ident.create "spacetime_node" in
+      reset ~spacetime_node_ident:node ~function_label:f.Cmm.fun_name
+    end;
+    super#emit_fundecl f
+
+  method! insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env =
+    let fun_spacetime_shape =
+      super#insert_prologue f ~loc_arg ~rarg ~spacetime_node_hole ~env
+    in
+    (* CR-soon mshinwell: add check to make sure the node size doesn't exceed
+       the chunk size of the allocator *)
+    if not Config.spacetime then fun_spacetime_shape
+    else begin
+      let node_hole, node_hole_reg =
+        match spacetime_node_hole with
+        | None -> assert false
+        | Some (node_hole, reg) -> node_hole, reg
+      in
+      self#insert_moves [| Proc.loc_spacetime_node_hole |] node_hole_reg;
+      self#emit_prologue f ~node_hole ~env;
+      match !reverse_shape with
+      | [] -> None
+      (* N.B. We do not reverse the shape list, since the function that
+         reconstructs it (caml_spacetime_shape_table) reverses it again. *)
+      | reverse_shape -> Some reverse_shape
+    end
+end

diff --git a/asmcomp/spacetime_profiling.mli b/asmcomp/spacetime_profiling.mli
new file mode 100644 (file)
index 0000000..16c6914
--- /dev/null
+++ b/asmcomp/spacetime_profiling.mli
@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Insertion of instrumentation code for Spacetime profiling. *)
+
+class virtual instruction_selection : Selectgen.selector_generic

diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml
index 6c4cf458d1ca1afcae080fb49f04eda8c54096d0..7d246ba372fb6fadc3e3f58be77b5af86f04e557 100644 (file)
--- a/asmcomp/sparc/CSE.ml
+++ b/asmcomp/sparc/CSE.ml
@@ -18,13 +18,13 @@
 open Mach
 open CSEgen
 
-class cse = object (self)
+class cse = object
 
 inherit cse_generic (* as super *)
 
 method! is_cheap_operation op =
   match op with
-  | Iconst_int n | Iconst_blockheader n -> n <= 4095n && n >= -4096n
+  | Iconst_int n -> n <= 4095n && n >= -4096n
   | _ -> false
 
 end

diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml
index f7e388be7b33d72fa43cf0e156d8fdc0cc483574..1f7e2abdeff78083d5579159b45ad6a8506c9f06 100644 (file)
--- a/asmcomp/sparc/arch.ml
+++ b/asmcomp/sparc/arch.ml
@@ -33,6 +33,8 @@ let command_line_options =
 
 type specific_operation = unit          (* None worth mentioning *)
 
+let spacetime_node_hole_pointer_is_live_before _specific_op = false
+
 (* Addressing modes *)
 
 type addressing_mode =
@@ -63,8 +65,8 @@ let offset_addressing addr delta =
   | Iindexed n -> Iindexed(n + delta)
 
 let num_args_addressing = function
-    Ibased(s, n) -> 0
-  | Iindexed n -> 1
+    Ibased _ -> 0
+  | Iindexed _ -> 1
 
 (* Printing operations and addressing modes *)
 
@@ -77,5 +79,5 @@ let print_addressing printreg addr ppf arg =
       let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
       fprintf ppf "%a%s" printreg arg.(0) idx
 
-let print_specific_operation printreg op ppf arg =
+let print_specific_operation _printreg _op _ppf _arg =
   Misc.fatal_error "Arch_sparc.print_specific_operation"

diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp
index 74d61be202067b6bd636fae0f3c952b77d68306a..78d0098d8f7b0aa54f8d2ca91d0ae8ff69dfec5a 100644 (file)
--- a/asmcomp/sparc/emit.mlp
+++ b/asmcomp/sparc/emit.mlp
@@ -1,3 +1,4 @@
+#2 "asmcomp/sparc/emit.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -98,9 +99,6 @@ let label_prefix =
 let emit_label lbl =
   emit_string label_prefix; emit_int lbl
 
-let emit_data_label lbl =
-  emit_string label_prefix; emit_string "d"; emit_int lbl
-
 (* Output a pseudo-register *)
 
 let emit_reg r =
@@ -163,8 +161,12 @@ type frame_descr =
 
 let frame_descriptors = ref([] : frame_descr list)
 
-let record_frame live =
-  let lbl = new_label() in
+let record_frame ?label live =
+  let lbl =
+    match label with
+    | None -> new_label()
+    | Some label -> label
+  in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
@@ -278,16 +280,16 @@ let rec emit_instr i dslot =
     | Lop(Imove | Ispill | Ireload) ->
         let src = i.arg.(0) and dst = i.res.(0) in
         begin match (src, dst) with
-            {loc = Reg rs; typ = (Int | Addr | Val)}, {loc = Reg rd} ->
+            {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
               `        mov     {emit_reg src}, {emit_reg dst}\n`
-          | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
+          | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
               if !arch_version = SPARC_V9 then
                 `      fmovd   {emit_reg src}, {emit_reg dst}\n`
               else begin
                 `      fmovs   {emit_reg src}, {emit_reg dst}\n`;
                 `      fmovs   {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n`
               end
-          | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = (Int | Addr | Val)} ->
+          | {loc = Reg _; typ = Float}, {loc = Reg _; typ = (Int | Addr | Val)} ->
               (* This happens when calling C functions and passing a float arg
                  in %o0...%o5 *)
               `        sub     %sp, 8, %sp\n`;
@@ -304,18 +306,18 @@ let rec emit_instr i dslot =
                     fatal_error "Emit: Imove Float [| _; _ |]"
               end;
               `        add     %sp, 8, %sp\n`
-          | {loc = Reg rs; typ = (Int | Addr | Val)}, {loc = Stack sd} ->
+          | {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Stack _} ->
               `        st      {emit_reg src}, {emit_stack dst}\n`
-          | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
+          | {loc = Reg _; typ = Float}, {loc = Stack _} ->
               `        std     {emit_reg src}, {emit_stack dst}\n`
-          | {loc = Stack ss; typ = (Int | Addr | Val)}, {loc = Reg rd} ->
+          | {loc = Stack _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
               `        ld      {emit_stack src}, {emit_reg dst}\n`
-          | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
+          | {loc = Stack _; typ = Float}, {loc = Reg _} ->
               `        ldd     {emit_stack src}, {emit_reg dst}\n`
           | (_, _) ->
               fatal_error "Emit: Imove"
         end
-    | Lop(Iconst_int n | Iconst_blockheader n) ->
+    | Lop(Iconst_int n) ->
         if is_native_immediate n then
           `    mov     {emit_nativeint n}, {emit_reg i.res.(0)}\n`
         else begin
@@ -332,37 +334,37 @@ let rec emit_instr i dslot =
     | Lop(Iconst_symbol s) ->
         `      sethi   %hi({emit_symbol s}), %g1\n`;
         `      or      %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n`
-    | Lop(Icall_ind) ->
-        `{record_frame i.live} call    {emit_reg i.arg.(0)}\n`;
+    | Lop(Icall_ind { label_after; }) ->
+        `{record_frame i.live ~label:label_after}      call    {emit_reg i.arg.(0)}\n`;
         fill_delay_slot dslot
-    | Lop(Icall_imm s) ->
-        `{record_frame i.live} call    {emit_symbol s}\n`;
+    | Lop(Icall_imm { func; label_after; }) ->
+        `{record_frame i.live ~label:label_after}      call    {emit_symbol func}\n`;
         fill_delay_slot dslot
-    | Lop(Itailcall_ind) ->
+    | Lop(Itailcall_ind { label_after = _; }) ->
         let n = frame_size() in
         if !contains_calls then
           `    ld      [%sp + {emit_int(n - 4 + 96)}], %o7\n`;
         `      jmp     {emit_reg i.arg.(0)}\n`;
         `      add     %sp, {emit_int n}, %sp\n` (* in delay slot *)
-    | Lop(Itailcall_imm s) ->
+    | Lop(Itailcall_imm { func; label_after = _; }) ->
         let n = frame_size() in
-        if s = !function_name then begin
+        if func = !function_name then begin
             `  b       {emit_label !tailrec_entry_point}\n`;
             fill_delay_slot dslot
         end else begin
           if !contains_calls then
             `  ld      [%sp + {emit_int(n - 4 + 96)}], %o7\n`;
-          `    sethi   %hi({emit_symbol s}), %g1\n`;
-          `    jmp     %g1 + %lo({emit_symbol s})\n`;
+          `    sethi   %hi({emit_symbol func}), %g1\n`;
+          `    jmp     %g1 + %lo({emit_symbol func})\n`;
           `    add     %sp, {emit_int n}, %sp\n` (* in delay slot *)
         end
-    | Lop(Iextcall(s, alloc)) ->
+    | Lop(Iextcall { func; alloc; label_after; }) ->
         if alloc then begin
-          `    sethi   %hi({emit_symbol s}), %g2\n`;
-          `{record_frame i.live}       call    {emit_symbol "caml_c_call"}\n`;
-          `    or      %g2, %lo({emit_symbol s}), %g2\n` (* in delay slot *)
+          `    sethi   %hi({emit_symbol func}), %g2\n`;
+          `{record_frame i.live ~label:label_after}    call    {emit_symbol "caml_c_call"}\n`;
+          `    or      %g2, %lo({emit_symbol func}), %g2\n` (* in delay slot *)
         end else begin
-          `    call    {emit_symbol s}\n`;
+          `    call    {emit_symbol func}\n`;
           fill_delay_slot dslot
         end
     | Lop(Istackoffset n) ->
@@ -406,7 +408,7 @@ let rec emit_instr i dslot =
               | _ -> "st" in
             emit_store storeinstr addr i.arg src
         end
-    | Lop(Ialloc n) ->
+    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
         if !fastcode_flag then begin
           let lbl_cont = new_label() in
           if solaris then begin
@@ -419,7 +421,7 @@ let rec emit_instr i dslot =
           end;
           `    bgeu    {emit_label lbl_cont}\n`;
           `    add     %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *)
-          `{record_frame i.live}       call    {emit_symbol "caml_call_gc"}\n`;
+          `{record_frame i.live ?label:label_after_call_gc}    call    {emit_symbol "caml_call_gc"}\n`;
           `    mov     {emit_int n}, %g2\n`; (* in delay slot *)
           `    add     %l6, 4, {emit_reg i.res.(0)}\n`;
           `{emit_label lbl_cont}:\n`
@@ -443,7 +445,7 @@ let rec emit_instr i dslot =
           `    mov     0, {emit_reg i.res.(0)}\n`;
           `{emit_label lbl}:\n`
         end
-    | Lop(Iintop Icheckbound) ->
+    | Lop(Iintop (Icheckbound _)) ->
         `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         if solaris then
           `    tleu    5\n`            (* 5 = ST_RANGE_CHECK *)
@@ -479,7 +481,7 @@ let rec emit_instr i dslot =
           `    mov     0, {emit_reg i.res.(0)}\n`;
           `{emit_label lbl}:\n`
         end
-    | Lop(Iintop_imm(Icheckbound, n)) ->
+    | Lop(Iintop_imm(Icheckbound _, n)) ->
         `      cmp     {emit_reg i.arg.(0)}, {emit_int n}\n`;
         if solaris then
           `    tleu    5\n`            (* 5 = ST_RANGE_CHECK *)
@@ -514,7 +516,7 @@ let rec emit_instr i dslot =
         `      st      %f30, [%sp + 96]\n`;
         `      ld      [%sp + 96], {emit_reg i.res.(0)}\n`;
         `      add     %sp, 8, %sp\n`
-    | Lop(Ispecific sop) ->
+    | Lop(Ispecific _) ->
        assert false
     | Lreloadretaddr ->
         let n = frame_size() in
@@ -613,7 +615,7 @@ and fill_delay_slot = function
    that does not branch. *)
 
 let is_one_instr_op = function
-    Imulh | Idiv | Imod | Icomp _ | Icheckbound -> false
+    Imulh | Idiv | Imod | Icomp _ | Icheckbound _ -> false
   | _ -> true
 
 let is_one_instr i =
@@ -622,7 +624,7 @@ let is_one_instr i =
       begin match op with
         Imove | Ispill | Ireload ->
           i.arg.(0).typ <> Float && i.res.(0).typ <> Float
-      | Iconst_int n | Iconst_blockheader n -> is_native_immediate n
+      | Iconst_int n -> is_native_immediate n
       | Istackoffset _ -> true
       | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n
       | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n
@@ -650,15 +652,16 @@ let no_interference res arg =
 let rec emit_all i =
   match i with
     {desc = Lend} -> ()
-  | {next = {desc = Lop(Icall_imm _) | Lop(Iextcall(_, false)) | Lbranch _}}
+  | {next = {desc = Lop(Icall_imm _)
+  | Lop(Iextcall { alloc = false; }) | Lbranch _}}
     when is_one_instr i ->
       emit_instr i.next (Some i);
       emit_all i.next.next
-  | {next = {desc = Lop(Itailcall_imm s)}}
-    when s = !function_name && is_one_instr i ->
+  | {next = {desc = Lop(Itailcall_imm { func; _ })}}
+    when func = !function_name && is_one_instr i ->
       emit_instr i.next (Some i);
       emit_all i.next.next
-  | {next = {desc = Lop(Icall_ind)}}
+  | {next = {desc = Lop(Icall_ind _)}}
     when is_one_instr i && no_interference i.res i.next.arg ->
       emit_instr i.next (Some i);
       emit_all i.next.next
@@ -708,8 +711,6 @@ let emit_item = function
       `        .global {emit_symbol s}\n`;
   | Cdefine_symbol s ->
       `{emit_symbol s}:\n`
-  | Cdefine_label lbl ->
-      `{emit_data_label lbl}:\n`
   | Cint8 n ->
       `        .byte   {emit_int n}\n`
   | Cint16 n ->
@@ -724,8 +725,6 @@ let emit_item = function
       emit_float64_split_directive ".word" (Int64.bits_of_float f)
   | Csymbol_address s ->
       `        .word   {emit_symbol s}\n`
-  | Clabel_address lbl ->
-      `        .word   {emit_data_label lbl}\n`
   | Cstring s ->
       emit_string_directive "  .ascii  " s
   | Cskip n ->

diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml
index 78062f311deb7ec88d504fb4828bc1436ea458e8..04f3b19c196a4ac6b2a7ecdc82fc2cbba230583e 100644 (file)
--- a/asmcomp/sparc/proc.ml
+++ b/asmcomp/sparc/proc.ml
@@ -103,6 +103,8 @@ let phys_reg n =
 let stack_slot slot ty =
   Reg.at_location ty (Stack slot)
 
+let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
+
 (* Calling conventions *)
 
 let calling_conventions first_int last_int first_float last_float make_stack
@@ -134,16 +136,16 @@ let calling_conventions first_int last_int first_float last_float make_stack
 
 let incoming ofs = Incoming ofs
 let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
+let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
 
 let max_arguments_for_tailcalls = 10
 
 let loc_arguments arg =
   calling_conventions 6 15 100 105 outgoing arg
 let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 6 15 100 105 incoming arg in loc
+  let (loc, _ofs) = calling_conventions 6 15 100 105 incoming arg in loc
 let loc_results res =
-  let (loc, ofs) = calling_conventions 0 5 100 105 not_supported res in loc
+  let (loc, _ofs) = calling_conventions 0 5 100 105 not_supported res in loc
 
 (* On the Sparc, all arguments to C functions, even floating-point arguments,
    are passed in %o0..%o5, then on the stack *)
@@ -187,13 +189,13 @@ let loc_external_arguments arg =
   (loc, Misc.align (!ofs + 4) 8)
 
 let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 1 100 100 not_supported res in loc
+  let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported res in loc
 
 let loc_exn_bucket = phys_reg 0         (* $o0 *)
 
 (* Volatile registers: none *)
 
-let regs_are_volatile rs = false
+let regs_are_volatile _rs = false
 
 (* Registers destroyed by operations *)
 
@@ -204,8 +206,9 @@ let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *)
      108; 109; 110; 111; 112; 113; 114])
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
+    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
+    all_phys_regs
+  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
   | _ -> [||]
 
 let destroyed_at_raise = all_phys_regs
@@ -213,20 +216,20 @@ let destroyed_at_raise = all_phys_regs
 (* Maximal register pressure *)
 
 let safe_register_pressure = function
-    Iextcall(_, _) -> 0
+    Iextcall _ -> 0
   | _ -> 15
 
 let max_register_pressure = function
-    Iextcall(_, _) -> [| 11; 0 |]
+    Iextcall _ -> [| 11; 0 |]
   | _ -> [| 19; 15 |]
 
 (* Pure operations (without any side effect besides updating their result
    registers). *)
 
 let op_is_pure = function
-  | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
+  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
   | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false
+  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
   | _ -> true
 
 (* Layout of the stack *)

diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml
index 5935ebf737ce66485307680d509dc2aa30ec1920..c169b475019409b4a7941a2db3155b29940d5135 100644 (file)
--- a/asmcomp/sparc/scheduling.ml
+++ b/asmcomp/sparc/scheduling.ml
@@ -49,9 +49,9 @@ method oper_issue_cycles = function
   | Iconst_symbol _ -> 2
   | Ialloc _ -> 6
   | Iintop(Icomp _) -> 4
-  | Iintop(Icheckbound) -> 2
+  | Iintop(Icheckbound _) -> 2
   | Iintop_imm(Icomp _, _) -> 4
-  | Iintop_imm(Icheckbound, _) -> 2
+  | Iintop_imm(Icheckbound _, _) -> 2
   | Inegf -> 2
   | Iabsf -> 2
   | Ifloatofint -> 6

diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml
index 288c0cb62f7313d6df6863ab519036c59b5f762c..c78a5f6560a536e5e95fc2d0bc82b689a7b54e50 100644 (file)
--- a/asmcomp/sparc/selection.ml
+++ b/asmcomp/sparc/selection.ml
@@ -26,7 +26,7 @@ inherit Selectgen.selector_generic as super
 
 method is_immediate n = (n <= 4095) && (n >= -4096)
 
-method select_addressing chunk = function
+method select_addressing _chunk = function
     Cconst_symbol s ->
       (Ibased(s, 0), Ctuple [])
   | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n]) ->
@@ -38,6 +38,9 @@ method select_addressing chunk = function
   | arg ->
       (Iindexed 0, arg)
 
+method private iextcall (func, alloc) =
+  Iextcall { func; alloc; label_after = Cmm.new_label (); }
+
 method! select_operation op args =
   match (op, args) with
   (* For SPARC V7 multiplication, division and modulus are turned into
@@ -45,11 +48,11 @@ method! select_operation op args =
      For SPARC V8 and V9, use hardware multiplication and division,
      but C library routine for modulus. *)
     (Cmuli, _) when !arch_version = SPARC_V7 ->
-      (Iextcall(".umul", false), args)
+      (self#iextcall(".umul", false), args)
   | (Cdivi, _) when !arch_version = SPARC_V7 ->
-      (Iextcall(".div", false), args)
+      (self#iextcall(".div", false), args)
   | (Cmodi, _) ->
-      (Iextcall(".rem", false), args)
+      (self#iextcall(".rem", false), args)
   | _ ->
       super#select_operation op args
 

diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml
index 7c755fce270e5ac1e5cd98d4e283d027d54c831d..d7a05697f64681c7414266758a12d1dc035e1c9d 100644 (file)
--- a/asmcomp/spill.ml
+++ b/asmcomp/spill.ml
@@ -72,7 +72,7 @@ let add_superpressure_regs op live_regs res_regs spilled =
     (fun r ->
       if Reg.Set.mem r spilled then () else begin
         match r.loc with
-          Stack s -> ()
+          Stack _ -> ()
         | _ -> let c = Proc.register_class r in
                pressure.(c) <- pressure.(c) + 1
       end)
@@ -139,10 +139,10 @@ let rec reload i before =
   match i.desc with
     Iend ->
       (i, before)
-  | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
+  | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) ->
       (add_reloads (Reg.inter_set_array before i.arg) i,
        Reg.Set.empty)
-  | Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) ->
+  | Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
       (* All regs live across must be spilled *)
       let (new_next, finally) = reload i.next i.live in
       (add_reloads (Reg.inter_set_array before i.arg)
@@ -286,7 +286,7 @@ let rec spill i finally =
   match i.desc with
     Iend ->
       (i, finally)
-  | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
+  | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) ->
       (i, Reg.Set.empty)
   | Iop Ireload ->
       let (new_next, after) = spill i.next finally in
@@ -298,8 +298,8 @@ let rec spill i finally =
       let before1 = Reg.diff_set_array after i.res in
       let before =
         match i.desc with
-          Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _)
-        | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) ->
+          Iop Icall_ind _ | Iop(Icall_imm _) | Iop(Iextcall _)
+        | Iop(Iintop (Icheckbound _)) | Iop(Iintop_imm((Icheckbound _), _)) ->
             Reg.Set.union before1 !spill_at_raise
         | _ ->
             before1 in
@@ -412,4 +412,6 @@ let fundecl f =
     fun_args = f.fun_args;
     fun_body = new_body;
     fun_fast = f.fun_fast;
-    fun_dbg  = f.fun_dbg }
+    fun_dbg  = f.fun_dbg;
+    fun_spacetime_shape = f.fun_spacetime_shape;
+  }

diff --git a/asmcomp/split.ml b/asmcomp/split.ml
index bac047e9b08d2b8b41d02133c3aa6c02914c7112..00b009ec79d0abeb18f81d5bced5dc5c7da714e9 100644 (file)
--- a/asmcomp/split.ml
+++ b/asmcomp/split.ml
@@ -87,8 +87,8 @@ let identify_sub sub1 sub2 reg =
 let merge_substs sub1 sub2 i =
   match (sub1, sub2) with
     (None, None) -> None
-  | (Some s1, None) -> sub1
-  | (None, Some s2) -> sub2
+  | (Some _, None) -> sub1
+  | (None, Some _) -> sub2
   | (Some s1, Some s2) ->
       Reg.Set.iter (identify_sub s1 s2) (Reg.add_set_array i.live i.arg);
       sub1
@@ -125,8 +125,8 @@ let rec rename i sub =
   match i.desc with
     Iend ->
       (i, sub)
-  | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
-      (instr_cons i.desc (subst_regs i.arg sub) [||] i.next,
+  | Ireturn | Iop(Itailcall_ind _) | Iop(Itailcall_imm _) ->
+      (instr_cons_debug i.desc (subst_regs i.arg sub) [||] i.dbg i.next,
        None)
   | Iop Ireload when i.res.(0).loc = Unknown ->
       begin match sub with
@@ -155,9 +155,9 @@ let rec rename i sub =
   | Iswitch(index, cases) ->
       let new_sub_cases = Array.map (fun c -> rename c sub) cases in
       let sub_merge =
-        merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in
+        merge_subst_array (Array.map (fun (_n, s) -> s) new_sub_cases) i.next in
       let (new_next, sub_next) = rename i.next sub_merge in
-      (instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases))
+      (instr_cons (Iswitch(index, Array.map (fun (n, _s) -> n) new_sub_cases))
                   (subst_regs i.arg sub) [||] new_next,
        sub_next)
   | Iloop(body) ->
@@ -206,7 +206,7 @@ let fundecl f =
   reset ();
 
   let new_args = Array.copy f.fun_args in
-  let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in
+  let (new_body, _sub_body) = rename f.fun_body (Some Reg.Map.empty) in
   repres_regs new_args;
   set_repres new_body;
   equiv_classes := Reg.Map.empty;
@@ -214,4 +214,6 @@ let fundecl f =
     fun_args = new_args;
     fun_body = new_body;
     fun_fast = f.fun_fast;
-    fun_dbg  = f.fun_dbg }
+    fun_dbg  = f.fun_dbg;
+    fun_spacetime_shape = f.fun_spacetime_shape;
+  }

diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml
index 7af65f648dcb8b701f3106fb2cc981f42e903b12..720bd645a74c32578e7991d9100faf52c446b211 100644 (file)
--- a/asmcomp/strmatch.ml
+++ b/asmcomp/strmatch.ml
@@ -368,7 +368,7 @@ module Make(I:I) = struct
 (* Module entry point *)
 
     let catch arg k = match arg with
-    | Cexit (e,[]) ->  k arg
+    | Cexit (_e,[]) ->  k arg
     | _ ->
         let e =  next_raise_count () in
         Ccatch (e,[],k (Cexit (e,[])),arg)

diff --git a/asmcomp/un_anf.ml b/asmcomp/un_anf.ml
index 15864c8bc1bcc2b3311201a125cf290cae6e0235..b87ac249d165c559fb56c70fa8bf49883b29ab76 100644 (file)
--- a/asmcomp/un_anf.ml
+++ b/asmcomp/un_anf.ml
@@ -101,8 +101,7 @@ let make_ident_info (clam : Clambda.ulambda) : ident_info =
     | Uoffset (expr, offset) ->
       loop expr;
       ignore_int offset
-    | Ulet (ident, def, body) ->
-      ignore ident;
+    | Ulet (_let_kind, _value_kind, _ident, def, body) ->
       loop def;
       loop body
     | Uletrec (defs, body) ->
@@ -267,7 +266,7 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) =
       (* [expr] should usually be a variable. *)
       examine_argument_list [expr];
       ignore_int offset
-    | Ulet (ident, def, body) ->
+    | Ulet (_let_kind, _value_kind, ident, def, body) ->
       begin match def with
       | Uconst _ ->
         (* The defining expression is obviously constant, so we don't
@@ -429,13 +428,14 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda)
   | Uoffset (clam, n) ->
     let clam = substitute_let_moveable is_let_moveable env clam in
     Uoffset (clam, n)
-  | Ulet (id, def, body) ->
+  | Ulet (let_kind, value_kind, id, def, body) ->
     let def = substitute_let_moveable is_let_moveable env def in
     if Ident.Set.mem id is_let_moveable then
       let env = Ident.Map.add id def env in
       substitute_let_moveable is_let_moveable env body
     else
-      Ulet (id, def, substitute_let_moveable is_let_moveable env body)
+      Ulet (let_kind, value_kind,
+            id, def, substitute_let_moveable is_let_moveable env body)
   | Uletrec (defs, body) ->
     let defs =
       List.map (fun (id, def) ->
@@ -520,18 +520,25 @@ and substitute_let_moveable_array is_let_moveable env clams =
 (* We say that an expression is "moveable" iff it has neither effects nor
    coeffects.  (See semantics_of_primitives.mli.)
 *)
-type moveable = Fixed | Moveable | Moveable_not_into_loops
+type moveable = Fixed | Constant | Moveable | Moveable_not_into_loops
 
 let both_moveable a b =
   match a, b with
+  | Constant, Constant -> Constant
+  | Constant, Moveable
+  | Moveable, Constant
   | Moveable, Moveable -> Moveable
+  | Moveable_not_into_loops, Constant
   | Moveable_not_into_loops, Moveable
+  | Constant, Moveable_not_into_loops
   | Moveable, Moveable_not_into_loops
   | Moveable_not_into_loops, Moveable_not_into_loops -> Moveable_not_into_loops
+  | Constant, Fixed
   | Moveable, Fixed
   | Moveable_not_into_loops, Fixed
-  | Fixed, Moveable_not_into_loops
+  | Fixed, Constant
   | Fixed, Moveable
+  | Fixed, Moveable_not_into_loops
   | Fixed, Fixed -> Fixed
 
 let primitive_moveable (prim : Lambda.primitive)
@@ -559,7 +566,7 @@ let primitive_moveable (prim : Lambda.primitive)
     | Arbitrary_effects, No_coeffects
     | Arbitrary_effects, Has_coeffects -> Fixed
 
-type moveable_for_env = Moveable | Moveable_not_into_loops
+type moveable_for_env = Constant | Moveable | Moveable_not_into_loops
 
 (** Called when we are entering a loop or body of a function (which may be
     called multiple times).  The environment is rewritten such that
@@ -567,6 +574,7 @@ type moveable_for_env = Moveable | Moveable_not_into_loops
 let going_into_loop env =
   Ident.Map.filter_map env ~f:(fun _var ((moveable : moveable_for_env), def) ->
     match moveable with
+    | Constant -> Some (Constant, def)
     | Moveable -> Some (Moveable, def)
     | Moveable_not_into_loops -> None)
 
@@ -577,6 +585,7 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
   match clam with
   | Uvar id ->
     begin match Ident.Map.find id env with
+    | Constant, def -> def, Constant
     | Moveable, def -> def, Moveable
     | Moveable_not_into_loops, def -> def, Moveable_not_into_loops
     | exception Not_found ->
@@ -590,7 +599,7 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
     end
   | Uconst _ ->
     (* Constant closures are rewritten separately. *)
-    clam, Moveable
+    clam, Constant
   | Udirect_apply (label, args, dbg) ->
     let args = un_anf_list ident_info env args in
     Udirect_apply (label, args, dbg), Fixed
@@ -613,40 +622,46 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
       both_moveable moveable Moveable_not_into_loops
   | Uoffset (clam, n) ->
     let clam, moveable = un_anf_and_moveable ident_info env clam in
-    Uoffset (clam, n), moveable
-  | Ulet (id, def, Uvar id') when Ident.same id id' ->
+    Uoffset (clam, n), both_moveable Moveable moveable
+  | Ulet (_let_kind, _value_kind, id, def, Uvar id') when Ident.same id id' ->
     un_anf_and_moveable ident_info env def
-  | Ulet (id, def, body) ->
+  | Ulet (let_kind, value_kind, id, def, body) ->
     let def, def_moveable = un_anf_and_moveable ident_info env def in
     let is_linear = Ident.Set.mem id ident_info.linear in
     let is_used = Ident.Set.mem id ident_info.used in
-    begin match def_moveable, is_linear, is_used with
-    | (Moveable | Moveable_not_into_loops), _, false ->
+    let is_assigned = Ident.Set.mem id ident_info.assigned in
+    begin match def_moveable, is_linear, is_used, is_assigned with
+    | (Constant | Moveable | Moveable_not_into_loops), _, false, _ ->
       (* A moveable expression that is never used may be eliminated. *)
       un_anf_and_moveable ident_info env body
-    | Moveable, true, true ->
-      (* A moveable expression bound to a linear [Ident.t] may replace the
-         single occurrence of the identifier. *)
-      let env =
-        let def_moveable : moveable_for_env =
-          match def_moveable with
-          | Moveable -> Moveable
-          | Moveable_not_into_loops -> Moveable_not_into_loops
-          | Fixed -> assert false
-        in
-        Ident.Map.add id (def_moveable, def) env
+    | Constant, _, true, false
+    (* A constant expression bound to an unassigned identifier can replace any
+         occurances of the identifier. *)
+    | Moveable, true, true, false  ->
+      (* A moveable expression bound to a linear unassigned [Ident.t]
+         may replace the single occurrence of the identifier. *)
+      let def_moveable =
+        match def_moveable with
+        | Moveable -> Moveable
+        | Constant -> Constant
+        | Moveable_not_into_loops -> Moveable_not_into_loops
+        | Fixed -> assert false
       in
+      let env = Ident.Map.add id (def_moveable, def) env in
       un_anf_and_moveable ident_info env body
-    | Moveable_not_into_loops, true, true
+    | Moveable_not_into_loops, true, true, false
         (* We can't delete the [let] binding in this case because we don't
            know whether the variable was substituted for its definition
            (in the case of its linear use not being inside a loop) or not.
            We could extend the code to cope with this case. *)
-    | (Moveable | Moveable_not_into_loops), false, true
+    | (Constant | Moveable | Moveable_not_into_loops), _, _, true
+        (* Constant or Moveable but assigned. *)
+    | (Moveable | Moveable_not_into_loops), false, _, _
         (* Moveable but not used linearly. *)
-    | Fixed, _, _ ->
+    | Fixed, _, _, _ ->
       let body, body_moveable = un_anf_and_moveable ident_info env body in
-      Ulet (id, def, body), both_moveable def_moveable body_moveable
+      Ulet (let_kind, value_kind, id, def, body),
+      both_moveable def_moveable body_moveable
     end
   | Uletrec (defs, body) ->
     let defs =

diff --git a/asmcomp/x86_dsl.ml b/asmcomp/x86_dsl.ml
index 6351c6a7a6229077e7c75951d5ce48ce238f5540..e647f66c67acbea3cd78733c650c15cd2c5a3a15 100644 (file)
--- a/asmcomp/x86_dsl.ml
+++ b/asmcomp/x86_dsl.ml
@@ -50,6 +50,7 @@ let ax  = Reg16 RAX
 let rax = Reg64 RAX
 let r10 = Reg64 R10
 let r11 = Reg64 R11
+let r13 = Reg64 R13
 let r14 = Reg64 R14
 let r15 = Reg64 R15
 let rsp = Reg64 RSP

diff --git a/asmcomp/x86_dsl.mli b/asmcomp/x86_dsl.mli
index d73770b27f0912b2ecfd6315c8ef6918ae668e45..080331fcee2fa5c71d9e7e713022144b677f659d 100644 (file)
--- a/asmcomp/x86_dsl.mli
+++ b/asmcomp/x86_dsl.mli
@@ -39,6 +39,7 @@ val ax: arg
 val rax: arg
 val r10: arg
 val r11: arg
+val r13: arg
 val r14: arg
 val r15: arg
 val rsp: arg

diff --git a/asmrun/.depend b/asmrun/.depend
index 7840f9c266d04c433be98ab621746155c69c93fb..276dd8b028cc80ef0bfce16be5068d3e110f4286 100644 (file)
--- a/asmrun/.depend
+++ b/asmrun/.depend
@@ -11,7 +11,8 @@ array.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/signals.h
+  ../byterun/caml/signals.h spacetime.h ../byterun/caml/io.h \
+  ../byterun/caml/stack.h
 backtrace.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -27,7 +28,8 @@ backtrace_prim.o: backtrace_prim.c ../byterun/caml/alloc.h \
   ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h
 callback.o: callback.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -45,7 +47,7 @@ compact.o: compact.c ../byterun/caml/address_class.h \
   ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
-  ../byterun/caml/weak.h
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
 compare.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
@@ -87,13 +89,14 @@ fail.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
-  ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \
-  ../byterun/caml/callback.h
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/roots.h ../byterun/caml/callback.h
 finalise.o: finalise.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
-  ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/roots.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/misc.h ../byterun/caml/compact.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/signals.h
@@ -120,8 +123,8 @@ gc_ctrl.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h stack.h \
-  ../byterun/caml/startup_aux.h
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
 globroots.o: globroots.c ../byterun/caml/memory.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \
@@ -173,8 +176,8 @@ main.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/sys.h
 major_gc.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
-  ../byterun/caml/misc.h ../byterun/caml/custom.h \
-  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
   ../byterun/caml/finalise.h ../byterun/caml/roots.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
@@ -227,17 +230,19 @@ natdynlink.o: natdynlink.c ../byterun/caml/misc.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h \
-  ../byterun/caml/callback.h ../byterun/caml/alloc.h \
-  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/fail.h ../byterun/caml/signals.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h ../byterun/caml/callback.h \
+  ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/fail.h \
+  ../byterun/caml/signals.h ../byterun/caml/hooks.h
 obj.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/prims.h
+  ../byterun/caml/address_class.h ../byterun/caml/prims.h spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
 parsing.o: parsing.c ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
@@ -257,7 +262,8 @@ roots.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/globroots.h stack.h
+  ../byterun/caml/address_class.h ../byterun/caml/globroots.h \
+  ../byterun/caml/stack.h
 signals.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -275,7 +281,41 @@ signals_asm.o: signals_asm.c ../byterun/caml/fail.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
   ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \
-  signals_osdep.h stack.h
+  signals_osdep.h ../byterun/caml/stack.h spacetime.h \
+  ../byterun/caml/io.h
+spacetime.o: spacetime.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h
+spacetime_offline.o: spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h spacetime.h ../config/s.h
+spacetime_snapshot.o: spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h
 startup.o: startup.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -287,8 +327,8 @@ startup.o: startup.c ../byterun/caml/callback.h \
   ../byterun/caml/io.h ../byterun/caml/memory.h \
   ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/printexc.h stack.h ../byterun/caml/startup_aux.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
 startup_aux.o: startup_aux.c ../byterun/caml/backtrace.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -310,7 +350,7 @@ sys.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/sys.h ../byterun/caml/version.h
 terminfo.o: terminfo.c ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
   ../byterun/caml/alloc.h ../byterun/caml/misc.h \
@@ -322,7 +362,7 @@ unix.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/sys.h ../byterun/caml/io.h
 weak.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -343,7 +383,8 @@ array.p.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/signals.h
+  ../byterun/caml/signals.h spacetime.h ../byterun/caml/io.h \
+  ../byterun/caml/stack.h
 backtrace.p.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -359,7 +400,8 @@ backtrace_prim.p.o: backtrace_prim.c ../byterun/caml/alloc.h \
   ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h
 callback.p.o: callback.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -377,7 +419,7 @@ compact.p.o: compact.c ../byterun/caml/address_class.h \
   ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
-  ../byterun/caml/weak.h
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
 compare.p.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
@@ -419,13 +461,14 @@ fail.p.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
-  ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \
-  ../byterun/caml/callback.h
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/roots.h ../byterun/caml/callback.h
 finalise.p.o: finalise.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
-  ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/roots.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/misc.h ../byterun/caml/compact.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/signals.h
@@ -452,8 +495,8 @@ gc_ctrl.p.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h stack.h \
-  ../byterun/caml/startup_aux.h
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
 globroots.p.o: globroots.c ../byterun/caml/memory.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \
@@ -505,8 +548,8 @@ main.p.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/sys.h
 major_gc.p.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
-  ../byterun/caml/misc.h ../byterun/caml/custom.h \
-  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
   ../byterun/caml/finalise.h ../byterun/caml/roots.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
@@ -559,17 +602,19 @@ natdynlink.p.o: natdynlink.c ../byterun/caml/misc.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h \
-  ../byterun/caml/callback.h ../byterun/caml/alloc.h \
-  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/fail.h ../byterun/caml/signals.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h ../byterun/caml/callback.h \
+  ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/fail.h \
+  ../byterun/caml/signals.h ../byterun/caml/hooks.h
 obj.p.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/prims.h
+  ../byterun/caml/address_class.h ../byterun/caml/prims.h spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
 parsing.p.o: parsing.c ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
@@ -589,7 +634,8 @@ roots.p.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/globroots.h stack.h
+  ../byterun/caml/address_class.h ../byterun/caml/globroots.h \
+  ../byterun/caml/stack.h
 signals.p.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -607,7 +653,41 @@ signals_asm.p.o: signals_asm.c ../byterun/caml/fail.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
   ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \
-  signals_osdep.h stack.h
+  signals_osdep.h ../byterun/caml/stack.h spacetime.h \
+  ../byterun/caml/io.h
+spacetime.p.o: spacetime.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h
+spacetime_offline.p.o: spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h spacetime.h ../config/s.h
+spacetime_snapshot.p.o: spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h
 startup.p.o: startup.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -619,8 +699,8 @@ startup.p.o: startup.c ../byterun/caml/callback.h \
   ../byterun/caml/io.h ../byterun/caml/memory.h \
   ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/printexc.h stack.h ../byterun/caml/startup_aux.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
 startup_aux.p.o: startup_aux.c ../byterun/caml/backtrace.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -642,7 +722,7 @@ sys.p.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/sys.h ../byterun/caml/version.h
 terminfo.p.o: terminfo.c ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
   ../byterun/caml/alloc.h ../byterun/caml/misc.h \
@@ -654,7 +734,7 @@ unix.p.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/sys.h ../byterun/caml/io.h
 weak.p.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -675,7 +755,8 @@ array.d.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/signals.h
+  ../byterun/caml/signals.h spacetime.h ../byterun/caml/io.h \
+  ../byterun/caml/stack.h
 backtrace.d.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -691,7 +772,8 @@ backtrace_prim.d.o: backtrace_prim.c ../byterun/caml/alloc.h \
   ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h
 callback.d.o: callback.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -709,7 +791,7 @@ compact.d.o: compact.c ../byterun/caml/address_class.h \
   ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
-  ../byterun/caml/weak.h
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
 compare.d.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
@@ -751,13 +833,14 @@ fail.d.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
-  ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \
-  ../byterun/caml/callback.h
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/roots.h ../byterun/caml/callback.h
 finalise.d.o: finalise.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
-  ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/roots.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/misc.h ../byterun/caml/compact.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/signals.h
@@ -784,8 +867,8 @@ gc_ctrl.d.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h stack.h \
-  ../byterun/caml/startup_aux.h
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
 globroots.d.o: globroots.c ../byterun/caml/memory.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \
@@ -837,8 +920,8 @@ main.d.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/sys.h
 major_gc.d.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
-  ../byterun/caml/misc.h ../byterun/caml/custom.h \
-  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
   ../byterun/caml/finalise.h ../byterun/caml/roots.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
@@ -891,17 +974,19 @@ natdynlink.d.o: natdynlink.c ../byterun/caml/misc.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h \
-  ../byterun/caml/callback.h ../byterun/caml/alloc.h \
-  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/fail.h ../byterun/caml/signals.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h ../byterun/caml/callback.h \
+  ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/fail.h \
+  ../byterun/caml/signals.h ../byterun/caml/hooks.h
 obj.d.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/prims.h
+  ../byterun/caml/address_class.h ../byterun/caml/prims.h spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
 parsing.d.o: parsing.c ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
@@ -921,7 +1006,8 @@ roots.d.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/globroots.h stack.h
+  ../byterun/caml/address_class.h ../byterun/caml/globroots.h \
+  ../byterun/caml/stack.h
 signals.d.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -939,7 +1025,41 @@ signals_asm.d.o: signals_asm.c ../byterun/caml/fail.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
   ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \
-  signals_osdep.h stack.h
+  signals_osdep.h ../byterun/caml/stack.h spacetime.h \
+  ../byterun/caml/io.h
+spacetime.d.o: spacetime.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h
+spacetime_offline.d.o: spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h spacetime.h ../config/s.h
+spacetime_snapshot.d.o: spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h
 startup.d.o: startup.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -951,8 +1071,8 @@ startup.d.o: startup.c ../byterun/caml/callback.h \
   ../byterun/caml/io.h ../byterun/caml/memory.h \
   ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/printexc.h stack.h ../byterun/caml/startup_aux.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
 startup_aux.d.o: startup_aux.c ../byterun/caml/backtrace.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -974,7 +1094,7 @@ sys.d.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/sys.h ../byterun/caml/version.h
 terminfo.d.o: terminfo.c ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
   ../byterun/caml/alloc.h ../byterun/caml/misc.h \
@@ -986,7 +1106,7 @@ unix.d.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/sys.h ../byterun/caml/io.h
 weak.d.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -1007,7 +1127,8 @@ array.i.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/signals.h
+  ../byterun/caml/signals.h spacetime.h ../byterun/caml/io.h \
+  ../byterun/caml/stack.h
 backtrace.i.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -1023,7 +1144,8 @@ backtrace_prim.i.o: backtrace_prim.c ../byterun/caml/alloc.h \
   ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h
 callback.i.o: callback.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -1041,7 +1163,7 @@ compact.i.o: compact.c ../byterun/caml/address_class.h \
   ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
-  ../byterun/caml/weak.h
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
 compare.i.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
@@ -1083,13 +1205,14 @@ fail.i.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
-  ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \
-  ../byterun/caml/callback.h
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/roots.h ../byterun/caml/callback.h
 finalise.i.o: finalise.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
-  ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/roots.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/misc.h ../byterun/caml/compact.h \
+  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
+  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/signals.h
@@ -1116,8 +1239,8 @@ gc_ctrl.i.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h stack.h \
-  ../byterun/caml/startup_aux.h
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
 globroots.i.o: globroots.c ../byterun/caml/memory.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \
@@ -1169,8 +1292,8 @@ main.i.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/sys.h
 major_gc.i.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
-  ../byterun/caml/misc.h ../byterun/caml/custom.h \
-  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h \
   ../byterun/caml/finalise.h ../byterun/caml/roots.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
@@ -1223,17 +1346,19 @@ natdynlink.i.o: natdynlink.c ../byterun/caml/misc.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h stack.h \
-  ../byterun/caml/callback.h ../byterun/caml/alloc.h \
-  ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/fail.h ../byterun/caml/signals.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stack.h ../byterun/caml/callback.h \
+  ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/fail.h \
+  ../byterun/caml/signals.h ../byterun/caml/hooks.h
 obj.i.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
   ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/prims.h
+  ../byterun/caml/address_class.h ../byterun/caml/prims.h spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
 parsing.i.o: parsing.c ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \
@@ -1253,7 +1378,8 @@ roots.i.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/globroots.h stack.h
+  ../byterun/caml/address_class.h ../byterun/caml/globroots.h \
+  ../byterun/caml/stack.h
 signals.i.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \
@@ -1271,7 +1397,41 @@ signals_asm.i.o: signals_asm.c ../byterun/caml/fail.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
   ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \
-  signals_osdep.h stack.h
+  signals_osdep.h ../byterun/caml/stack.h spacetime.h \
+  ../byterun/caml/io.h
+spacetime.i.o: spacetime.c ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h
+spacetime_offline.i.o: spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h spacetime.h ../config/s.h
+spacetime_snapshot.i.o: spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
+  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/sys.h spacetime.h
 startup.i.o: startup.c ../byterun/caml/callback.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -1283,8 +1443,8 @@ startup.i.o: startup.c ../byterun/caml/callback.h \
   ../byterun/caml/io.h ../byterun/caml/memory.h \
   ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/printexc.h stack.h ../byterun/caml/startup_aux.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
 startup_aux.i.o: startup_aux.c ../byterun/caml/backtrace.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
@@ -1306,7 +1466,7 @@ sys.i.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/sys.h ../byterun/caml/version.h
 terminfo.i.o: terminfo.c ../byterun/caml/config.h \
   ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \
   ../byterun/caml/alloc.h ../byterun/caml/misc.h \
@@ -1318,7 +1478,7 @@ unix.i.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
-  ../byterun/caml/sys.h
+  ../byterun/caml/sys.h ../byterun/caml/io.h
 weak.i.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
   ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \

diff --git a/asmrun/Makefile b/asmrun/Makefile
index 1673752d7a3fdf28a82efac15cb325b130ce75b6..9588c163901b3d043d154c1441f87dbc8b6feda6 100644 (file)
--- a/asmrun/Makefile
+++ b/asmrun/Makefile
@@ -17,8 +17,10 @@ include ../config/Makefile
 
 CC=$(NATIVECC)
 FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \
-      -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) $(IFLEXDIR)
-CFLAGS=$(FLAGS) $(NATIVECCCOMPOPTS)
+      -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) $(IFLEXDIR) \
+      $(LIBUNWIND_INCLUDE_FLAGS)
+#CFLAGS=$(FLAGS) -g -O0
+CFLAGS=$(FLAGS) -g -O0 $(NATIVECCCOMPOPTS)
 DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS)
 IFLAGS=$(FLAGS) -DCAML_INSTR
 PFLAGS=$(FLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS) $(NATIVECCCOMPOPTS)
@@ -31,7 +33,8 @@ COBJS=startup_aux.o startup.o \
   gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \
   compact.o finalise.o custom.o $(UNIX_OR_WIN32).o backtrace_prim.o \
   backtrace.o \
-  natdynlink.o debugger.o meta.o dynlink.o clambda_checks.o
+  natdynlink.o debugger.o meta.o dynlink.o clambda_checks.o \
+  spacetime.o spacetime_snapshot.o spacetime_offline.o
 
 ASMOBJS=$(ARCH).o
 
@@ -204,7 +207,7 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
   compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \
   parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
   weak.c compact.c finalise.c meta.c custom.c main.c globroots.c \
-  $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c
+  $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c startup_aux.c backtrace.c
 
 clean::
        rm -f $(LINKEDFILES)

diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt
index 39a2f7e848ed37c348d796b8235729667ca8e042..b008fddcbf0748f2781b98ec50655e23e43ee650 100644 (file)
--- a/asmrun/Makefile.nt
+++ b/asmrun/Makefile.nt
@@ -27,7 +27,8 @@ COBJS=startup_aux.$(O) startup.$(O) \
   md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \
   weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \
   backtrace_prim.$(O) backtrace.$(O) \
-  natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) clambda_checks.$(O)
+  natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O) clambda_checks.$(O) \
+  spacetime.$(O) spacetime_snapshot.$(O) spacetime_offline.$(O)
 
 LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
   compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \

diff --git a/asmrun/amd64.S b/asmrun/amd64.S
index 5b2291ea2e818df4e920346f763cb0dd2d7b82bb..2d77e0f40af6703c47eac68baae4f3d92327b831 100644 (file)
--- a/asmrun/amd64.S
+++ b/asmrun/amd64.S
@@ -307,6 +307,9 @@ LBL(caml_call_gc):
     /* Save caml_young_ptr, caml_exception_pointer */
         STORE_VAR(%r15, caml_young_ptr)
         STORE_VAR(%r14, caml_exception_pointer)
+#ifdef WITH_SPACETIME
+        STORE_VAR(%r13, caml_spacetime_trie_node_ptr)
+#endif
     /* Save floating-point registers */
         subq    $(16*8), %rsp; CFI_ADJUST (16*8);
         movsd   %xmm0, 0*8(%rsp)
@@ -455,6 +458,11 @@ LBL(caml_c_call):
         popq    %r12; CFI_ADJUST(-8)
         STORE_VAR(%r12, caml_last_return_address)
         STORE_VAR(%rsp, caml_bottom_of_stack)
+#ifdef WITH_SPACETIME
+    /* Record the trie node hole pointer that corresponds to
+       [caml_last_return_address] */
+        STORE_VAR(%r13, caml_spacetime_trie_node_ptr)
+#endif
         subq    $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */
 #if !defined(SYS_mingw64) && !defined(SYS_cygwin)
     /* Touch the stack to trigger a recoverable segfault
@@ -483,10 +491,29 @@ FUNCTION(G(caml_start_program))
     /* Common code for caml_start_program and caml_callback* */
 LBL(caml_start_program):
     /* Build a callback link */
+#ifdef WITH_SPACETIME
+        PUSH_VAR(caml_spacetime_trie_node_ptr)
+#else
         subq    $8, %rsp; CFI_ADJUST (8)        /* stack 16-aligned */
+#endif
         PUSH_VAR(caml_gc_regs)
         PUSH_VAR(caml_last_return_address)
         PUSH_VAR(caml_bottom_of_stack)
+#ifdef WITH_SPACETIME
+        /* Save arguments to caml_callback* */
+        pushq   %rax; CFI_ADJUST (8)
+        pushq   %rbx; CFI_ADJUST (8)
+        pushq   %rdi; CFI_ADJUST (8)
+        pushq   %rsi; CFI_ADJUST (8)
+        /* No need to push %r12: it's callee-save. */
+        movq    %r12, %rdi
+        LEA_VAR(caml_start_program, %rsi)
+        call    GCALL(caml_spacetime_c_to_ocaml)
+        popq    %rsi; CFI_ADJUST (-8)
+        popq    %rdi; CFI_ADJUST (-8)
+        popq    %rbx; CFI_ADJUST (-8)
+        popq    %rax; CFI_ADJUST (-8)
+#endif
     /* Setup alloc ptr and exception ptr */
         LOAD_VAR(caml_young_ptr, %r15)
         LOAD_VAR(caml_exception_pointer, %r14)
@@ -495,6 +522,9 @@ LBL(caml_start_program):
         pushq   %r13; CFI_ADJUST(8)
         pushq   %r14; CFI_ADJUST(8)
         movq    %rsp, %r14
+#ifdef WITH_SPACETIME
+        LOAD_VAR(caml_spacetime_trie_node_ptr, %r13)
+#endif
     /* Call the OCaml code */
         call    *%r12
 LBL(107):
@@ -509,7 +539,11 @@ LBL(109):
         POP_VAR(caml_bottom_of_stack)
         POP_VAR(caml_last_return_address)
         POP_VAR(caml_gc_regs)
+#ifdef WITH_SPACETIME
+        POP_VAR(caml_spacetime_trie_node_ptr)
+#else
         addq    $8, %rsp; CFI_ADJUST (-8);
+#endif
     /* Restore callee-save registers. */
         POP_CALLEE_SAVE_REGS
     /* Return to caller. */
@@ -545,8 +579,6 @@ CFI_STARTPROC
         popq    %r14
         ret
 LBL(110):
-        STORE_VAR32($0, caml_backtrace_pos)
-LBL(111):
         movq    %rax, %r12            /* Save exception bucket */
         movq    %rax, C_ARG_1         /* arg 1: exception bucket */
 #ifdef WITH_FRAME_POINTERS
@@ -568,15 +600,6 @@ LBL(111):
         ret
 CFI_ENDPROC
 
-FUNCTION(G(caml_reraise_exn))
-CFI_STARTPROC
-        TESTL_VAR($1, caml_backtrace_active)
-        jne     LBL(111)
-        movq    %r14, %rsp
-        popq    %r14
-        ret
-CFI_ENDPROC
-
 /* Raise an exception from C */
 
 FUNCTION(G(caml_raise_exception))
@@ -677,6 +700,22 @@ G(caml_system__frametable):
         .value  -1          /* negative frame size => use callback link */
         .value  0           /* no roots here */
         .align  EIGHT_ALIGN
+        .quad   16
+        .quad   0
+        .string "amd64.S"
+
+#ifdef WITH_SPACETIME
+        .data
+        .globl  G(caml_system__spacetime_shapes)
+        .align  EIGHT_ALIGN
+G(caml_system__spacetime_shapes):
+        .quad   G(caml_start_program)
+        .quad   2           /* indirect call point to OCaml code */
+        .quad   LBL(107)    /* in caml_start_program / caml_callback* */
+        .quad   0           /* end of shapes for caml_start_program */
+        .quad   0           /* end of shape table */
+        .align  EIGHT_ALIGN
+#endif
 
 #if defined(SYS_macosx)
         .literal16

diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm
index fe80895a25e9b6c7d5b15b192733d1770a2974b4..07ac45085d6e2e2d45de50c17cfa6db16d144840 100644 (file)
--- a/asmrun/amd64nt.asm
+++ b/asmrun/amd64nt.asm
@@ -309,8 +309,6 @@ caml_raise_exn:
         pop     r14                  ; Recover previous exception handler
         ret                          ; Branch to handler
 L110:
-        mov     caml_backtrace_pos, 0
-L111:
         mov     r12, rax             ; Save exception bucket in r12
         mov     rcx, rax             ; Arg 1: exception bucket
         mov     rdx, [rsp]           ; Arg 2: PC of raise
@@ -323,15 +321,6 @@ L111:
         pop     r14                  ; Recover previous exception handler
         ret                          ; Branch to handler
 
-        PUBLIC  caml_reraise_exn
-        ALIGN   16
-caml_reraise_exn:
-        test    caml_backtrace_active, 1
-        jne     L111
-        mov     rsp, r14             ; Cut stack
-        pop     r14                  ; Recover previous exception handler
-        ret                          ; Branch to handler
-
 ; Raise an exception from C
 
         PUBLIC  caml_raise_exception

diff --git a/asmrun/backtrace_prim.c b/asmrun/backtrace_prim.c
index 1078da1f72bc1d38743b2981643dcdcc52aeb423..2ecf159180dd55aec7160fbac671b349472bc7cc 100644 (file)
--- a/asmrun/backtrace_prim.c
+++ b/asmrun/backtrace_prim.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Stack backtrace for uncaught exceptions */
 
 #include <stdio.h>
@@ -25,21 +27,7 @@
 #include "caml/memory.h"
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
-#include "stack.h"
-
-/* In order to prevent the GC from walking through the debug information
-   (which have no headers), we transform frame_descr pointers into
-   31/63 bits ocaml integers by shifting them by 1 to the right. We do
-   not lose information as descr pointers are aligned.  */
-value caml_val_raw_backtrace_slot(backtrace_slot pc)
-{
-  return Val_long((uintnat)pc>>1);
-}
-
-backtrace_slot caml_raw_backtrace_slot_val(value v)
-{
-  return ((backtrace_slot)(Long_val(v)<<1));
-}
+#include "caml/stack.h"
 
 /* Returns the next frame descriptor (or NULL if none is available),
    and updates *pc and *sp to point to the following one.  */
@@ -167,49 +155,73 @@ CAMLprim value caml_get_current_callstack(value max_frames_value)
     for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
       frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
       Assert(descr != NULL);
-      Store_field(trace, trace_pos,
-                  caml_val_raw_backtrace_slot((backtrace_slot) descr));
+      Field(trace, trace_pos) = Val_backtrace_slot((backtrace_slot) descr);
     }
   }
 
   CAMLreturn(trace);
 }
 
-/* Extract location information for the given frame descriptor */
-void caml_extract_location_info(backtrace_slot slot,
-                                /*out*/ struct caml_loc_info * li)
+
+debuginfo caml_debuginfo_extract(backtrace_slot slot)
 {
   uintnat infoptr;
-  uint32_t info1, info2;
   frame_descr * d = (frame_descr *)slot;
 
+  if ((d->frame_size & 1) == 0) {
+    return NULL;
+  }
+  /* Recover debugging info */
+  infoptr = ((uintnat) d +
+             sizeof(char *) + sizeof(short) + sizeof(short) +
+             sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
+            & -sizeof(frame_descr *);
+  return *((debuginfo*)infoptr);
+}
+
+debuginfo caml_debuginfo_next(debuginfo dbg)
+{
+  uint32_t * infoptr;
+
+  if (dbg == NULL)
+    return NULL;
+
+  infoptr = dbg;
+  infoptr += 2; /* Two packed info fields */
+  return *((debuginfo*)infoptr);
+}
+
+/* Extract location information for the given frame descriptor */
+void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li)
+{
+  uint32_t info1, info2;
+
   /* If no debugging information available, print nothing.
      When everything is compiled with -g, this corresponds to
      compiler-inserted re-raise operations. */
-  if ((d->frame_size & 1) == 0) {
+  if (dbg == NULL) {
     li->loc_valid = 0;
     li->loc_is_raise = 1;
+    li->loc_is_inlined = 0;
     return;
   }
   /* Recover debugging info */
-  infoptr = ((uintnat) d +
-             sizeof(char *) + sizeof(short) + sizeof(short) +
-             sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
-            & -sizeof(frame_descr *);
-  info1 = ((uint32_t *)infoptr)[0];
-  info2 = ((uint32_t *)infoptr)[1];
+  info1 = ((uint32_t *)dbg)[0];
+  info2 = ((uint32_t *)dbg)[1];
   /* Format of the two info words:
        llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk
                           44       36         26                       2  0
                        (32+12)    (32+4)
-     k ( 2 bits): 0 if it's a call, 1 if it's a raise
-     n (24 bits): offset (in 4-byte words) of file name relative to infoptr
+     k ( 2 bits): 0 if it's a call
+                  1 if it's a raise
+     n (24 bits): offset (in 4-byte words) of file name relative to dbg
      l (20 bits): line number
      a ( 8 bits): beginning of character range
      b (10 bits): end of character range */
   li->loc_valid = 1;
-  li->loc_is_raise = (info1 & 3) != 0;
-  li->loc_filename = (char *) infoptr + (info1 & 0x3FFFFFC);
+  li->loc_is_raise = (info1 & 3) == 1;
+  li->loc_is_inlined = caml_debuginfo_next(dbg) != NULL;
+  li->loc_filename = (char *) dbg + (info1 & 0x3FFFFFC);
   li->loc_lnum = info2 >> 12;
   li->loc_startchr = (info2 >> 4) & 0xFF;
   li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26);

diff --git a/asmrun/fail.c b/asmrun/fail.c
index 4f03cc385f56f73d6635f7af2a8a5163d6f1919c..ba56c4770290f3dc948b65d785fb11b3ffe533ba 100644 (file)
--- a/asmrun/fail.c
+++ b/asmrun/fail.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Raising exceptions from C. */
 
 #include <stdio.h>
@@ -25,7 +27,7 @@
 #include "caml/mlvalues.h"
 #include "caml/printexc.h"
 #include "caml/signals.h"
-#include "stack.h"
+#include "caml/stack.h"
 #include "caml/roots.h"
 #include "caml/callback.h"
 

diff --git a/asmrun/i386.S b/asmrun/i386.S
index 55b6947dafce0414d62cc68a485fe4918a2b6699..9e0f2bdb921e51a748448faf822652bddc0c44a6 100644 (file)
--- a/asmrun/i386.S
+++ b/asmrun/i386.S
@@ -334,8 +334,6 @@ FUNCTION(caml_raise_exn)
         UNDO_ALIGN_STACK(8)
         ret
 LBL(110):
-        movl    $0, G(caml_backtrace_pos)
-LBL(111):
         movl    %eax, %esi          /* Save exception bucket in esi */
         movl    G(caml_exception_pointer), %edi /* SP of handler */
         movl    0(%esp), %eax       /* PC of raise */
@@ -353,16 +351,6 @@ LBL(111):
         ret
         CFI_ENDPROC
 
-FUNCTION(caml_reraise_exn)
-        CFI_STARTPROC
-        testl   $1, G(caml_backtrace_active)
-        jne     LBL(111)
-        movl    G(caml_exception_pointer), %esp
-        popl    G(caml_exception_pointer); CFI_ADJUST(-4)
-        UNDO_ALIGN_STACK(8)
-        ret
-        CFI_ENDPROC
-
 /* Raise an exception from C */
 
 FUNCTION(caml_raise_exception)

diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm
index 74d3ddfd0706e06f1d87c1935a52f32315cf8276..b67306769feca40a8c33f60c04c32791c0e5581f 100644 (file)
--- a/asmrun/i386nt.asm
+++ b/asmrun/i386nt.asm
@@ -208,8 +208,6 @@ _caml_raise_exn:
         pop     _caml_exception_pointer
         ret
 L110:
-        mov     _caml_backtrace_pos, 0
-L111:
         mov     esi, eax                ; Save exception bucket in esi
         mov     edi, _caml_exception_pointer ; SP of handler
         mov     eax, [esp]              ; PC of raise
@@ -224,16 +222,7 @@ L111:
         pop     _caml_exception_pointer
         ret
 
-        PUBLIC  _caml_reraise_exn
-        ALIGN   4
-_caml_reraise_exn:
-        test    _caml_backtrace_active, 1
-        jne     L111
-        mov     esp, _caml_exception_pointer
-        pop     _caml_exception_pointer
-        ret
-
-                                ; Raise an exception from C
+; Raise an exception from C
 
         PUBLIC  _caml_raise_exception
         ALIGN  4

diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c
index a502d4493ffed6d57db3333295fc8b2d3f0a1a78..1d90b69bc613e941a032392e602cd43f9903fe1f 100644 (file)
--- a/asmrun/natdynlink.c
+++ b/asmrun/natdynlink.c
@@ -13,16 +13,25 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 #include "caml/memory.h"
-#include "stack.h"
+#include "caml/stack.h"
 #include "caml/callback.h"
 #include "caml/alloc.h"
 #include "caml/intext.h"
 #include "caml/osdeps.h"
 #include "caml/fail.h"
 #include "caml/signals.h"
+#ifdef WITH_SPACETIME
+#include "spacetime.h"
+#endif
+
+#include "caml/hooks.h"
+
+CAMLexport void (*caml_natdynlink_hook)(void* handle, char* unit) = NULL;
 
 #include <stdio.h>
 #include <string.h>
@@ -36,8 +45,6 @@ static void *getsym(void *handle, char *module, char *name){
   return sym;
 }
 
-extern char caml_globals_map[];
-
 CAMLprim value caml_natdynlink_getmap(value unit)
 {
   return (value)caml_globals_map;
@@ -92,6 +99,11 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) {
   sym = optsym("__frametable");
   if (NULL != sym) caml_register_frametable(sym);
 
+#ifdef WITH_SPACETIME
+  sym = optsym("__spacetime_shapes");
+  if (NULL != sym) caml_spacetime_register_shapes(sym);
+#endif
+
   sym = optsym("__gc_roots");
   if (NULL != sym) caml_register_dyn_global(sym);
 
@@ -111,6 +123,8 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) {
     caml_ext_table_add(&caml_code_fragments_table, cf);
   }
 
+  if( caml_natdynlink_hook != NULL ) caml_natdynlink_hook(handle,unit);
+
   entrypoint = optsym("__entry");
   if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0);
   else result = Val_unit;

diff --git a/asmrun/power.S b/asmrun/power.S
index 7bfca5320599f7b6759b2c1fa5b0419c1ccb4a41..b58391edf005ac076e519fdd73b4e6123bdcb31d 100644 (file)
--- a/asmrun/power.S
+++ b/asmrun/power.S
@@ -380,9 +380,6 @@ FUNCTION(caml_raise_exn)
     /* Branch to handler */
         bctr
 .L111:
-        li      0, 0
-        Storeglobal32(0, caml_backtrace_pos, 11)
-.L112:
         mr      28, 3           /* preserve exn bucket in callee-save reg */
                                 /* arg1: exception bucket, already in r3 */
         mflr    4               /* arg2: PC of raise */
@@ -398,20 +395,6 @@ FUNCTION(caml_raise_exn)
         b       .L110           /* raise the exn */
 ENDFUNCTION(caml_raise_exn)
 
-FUNCTION(caml_reraise_exn)
-        Loadglobal32(0, caml_backtrace_active, 11)
-        cmpwi   0, 0
-        bne-    .L112
-    /* Pop trap frame */
-        lg      0, TRAP_HANDLER_OFFSET(29)
-        mr      1, 29
-        mtctr   0
-        lg      29, TRAP_PREVIOUS_OFFSET(1)
-        addi    1, 1, TRAP_SIZE
-    /* Branch to handler */
-        bctr
-ENDFUNCTION(caml_reraise_exn)
-
 /* Raise an exception from C */
 
 FUNCTION(caml_raise_exception)

diff --git a/asmrun/roots.c b/asmrun/roots.c
index 7bf25b2e60e7b49aa7a73d17e48620d2b273d40a..6307fd096ac7d37a00d7bc2c70f60532fb1f3a3b 100644 (file)
--- a/asmrun/roots.c
+++ b/asmrun/roots.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* To walk the memory roots for garbage collection */
 
 #include "caml/finalise.h"
@@ -22,7 +24,7 @@
 #include "caml/minor_gc.h"
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
-#include "stack.h"
+#include "caml/stack.h"
 #include "caml/roots.h"
 #include <string.h>
 #include <stdio.h>
@@ -83,7 +85,7 @@ static frame_descr * next_frame_descr(frame_descr * d) {
      sizeof(char *) + sizeof(short) + sizeof(short) +
      sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
     & -sizeof(frame_descr *);
-  if (d->frame_size & 1) nextd += 8;
+  if (d->frame_size & 1) nextd += sizeof(void *); /* pointer to debuginfo */
   return((frame_descr *) nextd);
 }
 
@@ -332,7 +334,7 @@ void caml_oldify_local_roots (void)
   /* Global C roots */
   caml_scan_global_young_roots(&caml_oldify_one);
   /* Finalised values */
-  caml_final_do_young_roots (&caml_oldify_one);
+  caml_final_oldify_young_roots ();
   /* Hook */
   if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one);
 }
@@ -426,7 +428,7 @@ void caml_do_roots (scanning_action f, int do_globals)
   caml_scan_global_roots(f);
   CAML_INSTR_TIME (tmr, "major_roots/C");
   /* Finalised values */
-  caml_final_do_strong_roots (f);
+  caml_final_do_roots (f);
   CAML_INSTR_TIME (tmr, "major_roots/finalised");
   /* Hook */
   if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);

diff --git a/asmrun/s390x.S b/asmrun/s390x.S
index 175ea6a0822809cd12da42b0cedb757924d745ca..0af419941090a8456787dfd6cc01917736d9f291 100644 (file)
--- a/asmrun/s390x.S
+++ b/asmrun/s390x.S
@@ -110,6 +110,7 @@ caml_call_gc:
         .type   caml_c_call, @function
 caml_c_call:
         Storeglobal(%r15, caml_bottom_of_stack)
+.L101:
     /* Save return address */
         ldgr    %f15, %r14
     /* Get ready to call C function (address in r7) */
@@ -125,10 +126,6 @@ caml_c_call:
     /* Reload allocation pointer and allocation limit*/
         Loadglobal(%r11, caml_young_ptr)
         Loadglobal(%r10, caml_young_limit)
-    /* Say we are back into OCaml code */
-        lgfi   %r0, 0
-        Storeglobal(%r0, caml_last_return_address)
-
     /* Return to caller */
         br %r14
 
@@ -148,9 +145,6 @@ caml_raise_exn:
     /* Branch to handler */
         br      %r1
 .L110:
-        lgfi      %r0, 0
-        Storeglobal32(%r0, caml_backtrace_pos)
-.L114:
         ldgr    %f15, %r2       /* preserve exn bucket in callee-save reg */
                                 /* arg1: exception bucket, already in r3 */
         lgr     %r3,%r14        /* arg2: PC of raise */
@@ -162,26 +156,12 @@ caml_raise_exn:
         lgdr    %r2,%f15        /* restore exn bucket */
         j       .L111           /* raise the exn */
 
-        .globl  caml_reraise_exn
-        .type   caml_reraise_exn, @function
-caml_reraise_exn:
-        Loadglobal32(%r0, caml_backtrace_active)
-        cgfi    %r0, 0
-        jne    .L114
-    /* Pop trap frame */
-        lg     %r1, 0(%r13)
-        lgr    %r15, %r13
-        lg    %r13, 8(%r13)
-        agfi   %r15, 16
-    /* Branch to handler */
-        br     %r1;
-
 /* Raise an exception from C */
 
         .globl  caml_raise_exception
         .type   caml_raise_exception, @function
 caml_raise_exception:
-        Loadglobal32(0, caml_backtrace_active)
+        Loadglobal32(%r0, caml_backtrace_active)
         cgfi    %r0, 0
         jne    .L112
 .L113:
@@ -189,9 +169,6 @@ caml_raise_exception:
         Loadglobal(%r15, caml_exception_pointer)
         Loadglobal(%r11, caml_young_ptr)
         Loadglobal(%r10, caml_young_limit)
-    /* Say we are back into OCaml code */
-        lgfi   %r0, 0
-        Storeglobal(%r0, caml_last_return_address)
     /* Pop trap frame */
         lg      %r1, 0(%r15)
         lg      %r13, 8(%r15)
@@ -199,6 +176,8 @@ caml_raise_exception:
     /* Branch to handler */
         br      %r1;
 .L112:
+        lgfi      %r0, 0
+        Storeglobal32(%r0, caml_backtrace_pos)
         ldgr    %f15,%r2        /* preserve exn bucket in callee-save reg */
                                 /* arg1: exception bucket, already in r2 */
         Loadglobal(%r3, caml_last_return_address) /* arg2: PC of raise */
@@ -335,9 +314,12 @@ caml_callback3_exn:
         .globl  caml_ml_array_bound_error
         .type   caml_ml_array_bound_error, @function
 caml_ml_array_bound_error:
+        /* Save return address before decrementing SP, otherwise
+           the frame descriptor for the call site is not correct */
+        Storeglobal(%r15, caml_bottom_of_stack)
         lay     %r15, -160(%r15)    /* Reserve stack space for C call */
         larl    %r7, caml_array_bound_error
-        j       caml_c_call
+        j       .L101
         .globl  caml_system__code_end
 caml_system__code_end:
 

diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c
index 449e2dad7f3f91c6ca7da9c9289c15191db778bd..d08e2dbe19ead13f711fc719850f5634534d7b5a 100644 (file)
--- a/asmrun/signals_asm.c
+++ b/asmrun/signals_asm.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Signal handling, code specific to the native-code compiler */
 
 #if defined(TARGET_amd64) && defined (SYS_linux)
@@ -27,7 +29,8 @@
 #include "caml/signals.h"
 #include "caml/signals_machdep.h"
 #include "signals_osdep.h"
-#include "stack.h"
+#include "caml/stack.h"
+#include "spacetime.h"
 
 #ifdef HAS_STACK_OVERFLOW_DETECTION
 #include <sys/time.h>
@@ -74,6 +77,13 @@ void caml_garbage_collection(void)
       caml_young_ptr - caml_young_trigger < Max_young_whsize){
     caml_gc_dispatch ();
   }
+
+#ifdef WITH_SPACETIME
+  if (caml_young_ptr == caml_young_alloc_end) {
+    caml_spacetime_automatic_snapshot();
+  }
+#endif
+
   caml_process_pending_signals();
 }
 

diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h
index dc2236ab1fce60ea6380437c977c88dec35a899d..03196167157b2822d02e30262d0e5b5a758bca5a 100644 (file)
--- a/asmrun/signals_osdep.h
+++ b/asmrun/signals_osdep.h
@@ -137,6 +137,23 @@
  #define CONTEXT_YOUNG_PTR (context->sc_r15)
  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
 
+/****************** AMD64, NetBSD */
+
+#elif defined(TARGET_amd64) && defined (SYS_netbsd)
+
+ #include <ucontext.h>
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ #define CONTEXT_PC (_UC_MACHINE_PC(context))
+ #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
+ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
 /****************** I386, Linux */
 
 #elif defined(TARGET_i386) && defined(SYS_linux_elf)
@@ -305,7 +322,8 @@
 
 /****************** PowerPC, BSD */
 
-#elif defined(TARGET_power) && (defined(SYS_bsd) || defined(SYS_bsd_elf))
+#elif defined(TARGET_power) && \
+    (defined(SYS_bsd) || defined(SYS_bsd_elf) || defined(SYS_netbsd))
 
   #define DECLARE_SIGNAL_HANDLER(name) \
     static void name(int sig, int code, struct sigcontext * context)

diff --git a/asmrun/spacetime.c b/asmrun/spacetime.c
new file mode 100644 (file)
index 0000000..b5e999f
--- /dev/null
+++ b/asmrun/spacetime.c
@@ -0,0 +1,1122 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2013--2016, Jane Street Group, LLC                         */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <signal.h>
+#include "caml/config.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+
+#include "caml/alloc.h"
+#include "caml/backtrace_prim.h"
+#include "caml/fail.h"
+#include "caml/gc.h"
+#include "caml/intext.h"
+#include "caml/major_gc.h"
+#include "caml/memory.h"
+#include "caml/minor_gc.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#include "caml/stack.h"
+#include "caml/sys.h"
+#include "spacetime.h"
+
+#ifdef WITH_SPACETIME
+
+/* We force "noinline" in certain places to be sure we know how many
+   frames there will be on the stack. */
+#define NOINLINE __attribute__((noinline))
+
+#ifdef HAS_LIBUNWIND
+#define UNW_LOCAL_ONLY
+#include "libunwind.h"
+#endif
+
+static int automatic_snapshots = 0;
+static double snapshot_interval = 0.0;
+static double next_snapshot_time = 0.0;
+static struct channel *snapshot_channel;
+static int pid_when_snapshot_channel_opened;
+
+extern value caml_spacetime_debug(value);
+
+static char* start_of_free_node_block;
+static char* end_of_free_node_block;
+
+typedef struct per_thread {
+  value* trie_node_root;
+  value* finaliser_trie_node_root;
+  struct per_thread* next;
+} per_thread;
+
+/* List of tries corresponding to threads that have been created. */
+/* CR-soon mshinwell: just include the main trie in this list. */
+static per_thread* per_threads = NULL;
+static int num_per_threads = 0;
+
+/* [caml_spacetime_shapes] is defined in the startup file. */
+extern uint64_t* caml_spacetime_shapes;
+
+uint64_t** caml_spacetime_static_shape_tables = NULL;
+shape_table* caml_spacetime_dynamic_shape_tables = NULL;
+
+static uintnat caml_spacetime_profinfo = (uintnat) 0;
+
+value caml_spacetime_trie_root = Val_unit;
+value* caml_spacetime_trie_node_ptr = &caml_spacetime_trie_root;
+
+static value caml_spacetime_finaliser_trie_root_main_thread = Val_unit;
+value* caml_spacetime_finaliser_trie_root
+  = &caml_spacetime_finaliser_trie_root_main_thread;
+
+/* CR-someday mshinwell: think about thread safety of the manipulation of
+   this list for multicore */
+allocation_point* caml_all_allocation_points = NULL;
+
+static const uintnat chunk_size = 1024 * 1024;
+
+static void reinitialise_free_node_block(void)
+{
+  size_t index;
+
+  start_of_free_node_block = (char*) malloc(chunk_size);
+  end_of_free_node_block = start_of_free_node_block + chunk_size;
+
+  for (index = 0; index < chunk_size / sizeof(value); index++) {
+    ((value*) start_of_free_node_block)[index] = Val_unit;
+  }
+}
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+#if defined (_WIN32) || defined (_WIN64)
+extern value val_process_id;
+#endif
+
+static uint32_t version_number = 0;
+static uint32_t magic_number_base = 0xace00ace;
+
+static void caml_spacetime_write_magic_number_internal(struct channel* chan)
+{
+  value magic_number =
+    Val_long(((uint64_t) magic_number_base)
+             | (((uint64_t) version_number) << 32));
+
+  Lock(chan);
+  caml_output_val(chan, magic_number, Val_long(0));
+  Unlock(chan);
+}
+
+CAMLprim value caml_spacetime_write_magic_number(value v_channel)
+{
+  caml_spacetime_write_magic_number_internal(Channel(v_channel));
+  return Val_unit;
+}
+
+static char* automatic_snapshot_dir;
+
+static void open_snapshot_channel(void)
+{
+  int fd;
+  char filename[8192];
+  int pid;
+#if defined (_WIN32) || defined (_WIN64)
+  pid = Int_val(val_process_id);
+#else
+  pid = getpid();
+#endif
+  snprintf(filename, 8192, "%s/spacetime-%d", automatic_snapshot_dir, pid);
+  filename[8191] = '\0';
+  fd = open(filename, O_WRONLY | O_CREAT | O_TRUNC | O_BINARY, 0666);
+  if (fd == -1) {
+    automatic_snapshots = 0;
+  }
+  else {
+    snapshot_channel = caml_open_descriptor_out(fd);
+    snapshot_channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE;
+    pid_when_snapshot_channel_opened = pid;
+    caml_spacetime_write_magic_number_internal(snapshot_channel);
+  }
+}
+
+static void maybe_reopen_snapshot_channel(void)
+{
+  /* This function should be used before writing to the automatic snapshot
+     channel.  It detects whether we have forked since the channel was opened.
+     If so, we close the old channel (ignoring any errors just in case the
+     old fd has been closed, e.g. in a double-fork situation where the middle
+     process has a loop to manually close all fds and no Spacetime snapshot
+     was written during that time) and then open a new one. */
+
+  int pid;
+#if defined (_WIN32) || defined (_WIN64)
+  pid = Int_val(val_process_id);
+#else
+  pid = getpid();
+#endif
+
+  if (pid != pid_when_snapshot_channel_opened) {
+    caml_close_channel(snapshot_channel);
+    open_snapshot_channel();
+  }
+}
+
+extern void caml_spacetime_automatic_save(void);
+
+void caml_spacetime_initialize(void)
+{
+  /* Note that this is called very early (even prior to GC initialisation). */
+
+  char *ap_interval;
+
+  reinitialise_free_node_block();
+
+  caml_spacetime_static_shape_tables = &caml_spacetime_shapes;
+
+  ap_interval = getenv ("OCAML_SPACETIME_INTERVAL");
+  if (ap_interval != NULL) {
+    unsigned int interval = 0;
+    sscanf(ap_interval, "%u", &interval);
+    if (interval != 0) {
+      double time;
+      char cwd[4096];
+      char* user_specified_automatic_snapshot_dir;
+      int dir_ok = 1;
+
+      user_specified_automatic_snapshot_dir =
+        getenv("OCAML_SPACETIME_SNAPSHOT_DIR");
+
+      if (user_specified_automatic_snapshot_dir == NULL) {
+#ifdef HAS_GETCWD
+        if (getcwd(cwd, sizeof(cwd)) == NULL) {
+          dir_ok = 0;
+        }
+#else
+        if (getwd(cwd) == NULL) {
+          dir_ok = 0;
+        }
+#endif
+        if (dir_ok) {
+          automatic_snapshot_dir = strdup(cwd);
+        }
+      }
+      else {
+        automatic_snapshot_dir =
+          strdup(user_specified_automatic_snapshot_dir);
+      }
+
+      if (dir_ok) {
+        automatic_snapshots = 1;
+        open_snapshot_channel();
+        if (automatic_snapshots) {
+#ifdef SIGINT
+          /* Catch interrupt so that the profile can be completed.
+             We do this by marking the signal as handled without
+             specifying an actual handler. This causes the signal
+             to be handled by a call to exit. */
+          caml_set_signal_action(SIGINT, 2);
+#endif
+          snapshot_interval = interval / 1e3;
+          time = caml_sys_time_unboxed(Val_unit);
+          next_snapshot_time = time + snapshot_interval;
+          atexit(&caml_spacetime_automatic_save);
+        }
+      }
+    }
+  }
+}
+
+void caml_spacetime_register_shapes(void* dynlinked_table)
+{
+  shape_table* table;
+  table = (shape_table*) malloc(sizeof(shape_table));
+  if (table == NULL) {
+    fprintf(stderr, "Out of memory whilst registering shape table");
+    abort();
+  }
+  table->table = (uint64_t*) dynlinked_table;
+  table->next = caml_spacetime_dynamic_shape_tables;
+  caml_spacetime_dynamic_shape_tables = table;
+}
+
+CAMLprim value caml_spacetime_trie_is_initialized (value v_unit)
+{
+  return (caml_spacetime_trie_root == Val_unit) ? Val_false : Val_true;
+}
+
+CAMLprim value caml_spacetime_get_trie_root (value v_unit)
+{
+  return caml_spacetime_trie_root;
+}
+
+void caml_spacetime_register_thread(
+  value* trie_node_root, value* finaliser_trie_node_root)
+{
+  per_thread* thr;
+
+  thr = (per_thread*) malloc(sizeof(per_thread));
+  if (thr == NULL) {
+    fprintf(stderr, "Out of memory while registering thread for profiling\n");
+    abort();
+  }
+  thr->next = per_threads;
+  per_threads = thr;
+
+  thr->trie_node_root = trie_node_root;
+  thr->finaliser_trie_node_root = finaliser_trie_node_root;
+
+  /* CR-soon mshinwell: record thread ID (and for the main thread too) */
+
+  num_per_threads++;
+}
+
+static void caml_spacetime_save_event_internal (value v_time_opt,
+                                                struct channel* chan,
+                                                value v_event_name)
+{
+  value v_time;
+  double time_override = 0.0;
+  int use_time_override = 0;
+
+  if (Is_block(v_time_opt)) {
+    time_override = Double_field(Field(v_time_opt, 0), 0);
+    use_time_override = 1;
+  }
+  v_time = caml_spacetime_timestamp(time_override, use_time_override);
+
+  Lock(chan);
+  caml_output_val(chan, Val_long(2), Val_long(0));
+  caml_output_val(chan, v_event_name, Val_long(0));
+  caml_extern_allow_out_of_heap = 1;
+  caml_output_val(chan, v_time, Val_long(0));
+  caml_extern_allow_out_of_heap = 0;
+  Unlock(chan);
+
+  caml_stat_free(Hp_val(v_time));
+}
+
+CAMLprim value caml_spacetime_save_event (value v_time_opt,
+                                          value v_channel,
+                                          value v_event_name)
+{
+  struct channel* chan = Channel(v_channel);
+
+  caml_spacetime_save_event_internal(v_time_opt, chan, v_event_name);
+
+  return Val_unit;
+}
+
+
+void save_trie (struct channel *chan, double time_override,
+                int use_time_override)
+{
+  value v_time, v_frames, v_shapes;
+  /* CR-someday mshinwell: The commented-out changes here are for multicore,
+     where we think we should have one trie per domain. */
+  /* int num_marshalled = 0;
+  per_thread* thr = per_threads; */
+
+  Lock(chan);
+
+  caml_output_val(chan, Val_long(1), Val_long(0));
+
+  v_time = caml_spacetime_timestamp(time_override, use_time_override);
+  v_frames = caml_spacetime_frame_table();
+  v_shapes = caml_spacetime_shape_table();
+
+  caml_extern_allow_out_of_heap = 1;
+  caml_output_val(chan, v_time, Val_long(0));
+  caml_output_val(chan, v_frames, Val_long(0));
+  caml_output_val(chan, v_shapes, Val_long(0));
+  caml_extern_allow_out_of_heap = 0;
+
+  caml_output_val(chan, Val_long(1) /* Val_long(num_per_threads + 1) */,
+    Val_long(0));
+
+  /* Marshal both the main and finaliser tries, for all threads that have
+     been created, to an [out_channel].  This can be done by using the
+     extern.c code as usual, since the trie looks like standard OCaml values;
+     but we must allow it to traverse outside the heap. */
+
+  caml_extern_allow_out_of_heap = 1;
+  caml_output_val(chan, caml_spacetime_trie_root, Val_long(0));
+  caml_output_val(chan,
+    caml_spacetime_finaliser_trie_root_main_thread, Val_long(0));
+  /* while (thr != NULL) {
+    caml_output_val(chan, *(thr->trie_node_root), Val_long(0));
+    caml_output_val(chan, *(thr->finaliser_trie_node_root),
+      Val_long(0));
+    thr = thr->next;
+    num_marshalled++;
+  }
+  Assert(num_marshalled == num_per_threads); */
+  caml_extern_allow_out_of_heap = 0;
+
+  Unlock(chan);
+}
+
+CAMLprim value caml_spacetime_save_trie (value v_time_opt, value v_channel)
+{
+  struct channel* channel = Channel(v_channel);
+  double time_override = 0.0;
+  int use_time_override = 0;
+
+  if (Is_block(v_time_opt)) {
+    time_override = Double_field(Field(v_time_opt, 0), 0);
+    use_time_override = 1;
+  }
+
+  save_trie(channel, time_override, use_time_override);
+
+  return Val_unit;
+}
+
+c_node_type caml_spacetime_classify_c_node(c_node* node)
+{
+  return (node->pc & 2) ? CALL : ALLOCATION;
+}
+
+c_node* caml_spacetime_c_node_of_stored_pointer(value node_stored)
+{
+  Assert(node_stored == Val_unit || Is_c_node(node_stored));
+  return (node_stored == Val_unit) ? NULL : (c_node*) Hp_val(node_stored);
+}
+
+c_node* caml_spacetime_c_node_of_stored_pointer_not_null(
+      value node_stored)
+{
+  Assert(Is_c_node(node_stored));
+  return (c_node*) Hp_val(node_stored);
+}
+
+value caml_spacetime_stored_pointer_of_c_node(c_node* c_node)
+{
+  value node;
+  Assert(c_node != NULL);
+  node = Val_hp(c_node);
+  Assert(Is_c_node(node));
+  return node;
+}
+
+#ifdef HAS_LIBUNWIND
+static int pc_inside_c_node_matches(c_node* node, void* pc)
+{
+  return Decode_c_node_pc(node->pc) == pc;
+}
+#endif
+
+static value allocate_uninitialized_ocaml_node(int size_including_header)
+{
+  void* node;
+  uintnat size;
+
+  Assert(size_including_header >= 3);
+  node = caml_stat_alloc(sizeof(uintnat) * size_including_header);
+
+  size = size_including_header * sizeof(value);
+
+  node = (void*) start_of_free_node_block;
+  if (end_of_free_node_block - start_of_free_node_block < size) {
+    reinitialise_free_node_block();
+    node = (void*) start_of_free_node_block;
+    Assert(end_of_free_node_block - start_of_free_node_block >= size);
+  }
+
+  start_of_free_node_block += size;
+
+  /* We don't currently rely on [uintnat] alignment, but we do need some
+     alignment, so just be sure. */
+  Assert (((uintnat) node) % sizeof(uintnat) == 0);
+  return Val_hp(node);
+}
+
+static value find_tail_node(value node, void* callee)
+{
+  /* Search the tail chain within [node] (which corresponds to an invocation
+     of a caller of [callee]) to determine whether it contains a tail node
+     corresponding to [callee].  Returns any such node, or [Val_unit] if no
+     such node exists. */
+
+  value starting_node;
+  value pc;
+  value found = Val_unit;
+
+  starting_node = node;
+  pc = Encode_node_pc(callee);
+
+  do {
+    Assert(Is_ocaml_node(node));
+    if (Node_pc(node) == pc) {
+      found = node;
+    }
+    else {
+      node = Tail_link(node);
+    }
+  } while (found == Val_unit && starting_node != node);
+
+  return found;
+}
+
+CAMLprim value caml_spacetime_allocate_node(
+      int size_including_header, void* pc, value* node_hole)
+{
+  value node;
+  value caller_node = Val_unit;
+
+  node = *node_hole;
+  /* The node hole should either contain [Val_unit], indicating that this
+     function was not tail called and we have not been to this point in the
+     trie before; or it should contain a value encoded using
+     [Encoded_tail_caller_node] that points at the node of a caller
+     that tail called the current function.  (Such a value is necessary to
+     be able to find the start of the caller's node, and hence its tail
+     chain, so we as a tail-called callee can link ourselves in.) */
+  Assert(Is_tail_caller_node_encoded(node));
+
+  if (node != Val_unit) {
+    value tail_node;
+    /* The callee was tail called.  Find whether there already exists a node
+       for it in the tail call chain within the caller's node.  The caller's
+       node must always be an OCaml node. */
+    caller_node = Decode_tail_caller_node(node);
+    tail_node = find_tail_node(caller_node, pc);
+    if (tail_node != Val_unit) {
+      /* This tail calling sequence has happened before; just fill the hole
+         with the existing node and return. */
+      *node_hole = tail_node;
+      return 0;  /* indicates an existing node was returned */
+    }
+  }
+
+  node = allocate_uninitialized_ocaml_node(size_including_header);
+  Hd_val(node) =
+    Make_header(size_including_header - 1, OCaml_node_tag, Caml_black);
+  Assert((((uintnat) pc) % 1) == 0);
+  Node_pc(node) = Encode_node_pc(pc);
+  /* If the callee was tail called, then the tail link field will link this
+     new node into an existing tail chain.  Otherwise, it is initialized with
+     the empty tail chain, i.e. the one pointing directly at [node]. */
+  if (caller_node == Val_unit) {
+    Tail_link(node) = node;
+  }
+  else {
+    Tail_link(node) = Tail_link(caller_node);
+    Tail_link(caller_node) = node;
+  }
+
+  /* The callee node pointers for direct tail call points are
+     initialized from code emitted by the OCaml compiler.  This is done to
+     avoid having to pass this function a description of which nodes are
+     direct tail call points.  (We cannot just count them and put them at the
+     beginning of the node because we need the indexes of elements within the
+     node during instruction selection before we have found all call points.)
+
+     All other fields have already been initialised by
+     [reinitialise_free_node_block].
+  */
+
+  *node_hole = node;
+
+  return 1;  /* indicates a new node was created */
+}
+
+static c_node* allocate_c_node(void)
+{
+  c_node* node;
+  size_t index;
+
+  node = (c_node*) start_of_free_node_block;
+  if (end_of_free_node_block - start_of_free_node_block < sizeof(c_node)) {
+    reinitialise_free_node_block();
+    node = (c_node*) start_of_free_node_block;
+    Assert(end_of_free_node_block - start_of_free_node_block
+      >= sizeof(c_node));
+  }
+  start_of_free_node_block += sizeof(c_node);
+
+  Assert((sizeof(c_node) % sizeof(uintnat)) == 0);
+
+  /* CR-soon mshinwell: remove this and pad the structure properly */
+  for (index = 0; index < sizeof(c_node) / sizeof(value); index++) {
+    ((value*) node)[index] = Val_unit;
+  }
+
+  node->gc_header =
+    Make_header(sizeof(c_node)/sizeof(uintnat) - 1, C_node_tag, Caml_black);
+  node->data.callee_node = Val_unit;
+  node->next = Val_unit;
+
+  return node;
+}
+
+/* Since a given indirect call site either always yields tail calls or
+   always yields non-tail calls, the output of
+   [caml_spacetime_indirect_node_hole_ptr] is uniquely determined by its
+   first two arguments (the callee and the node hole).  We cache these
+   to increase performance of recursive functions containing an indirect
+   call (e.g. [List.map] when not inlined). */
+static void* last_indirect_node_hole_ptr_callee;
+static value* last_indirect_node_hole_ptr_node_hole;
+static value* last_indirect_node_hole_ptr_result;
+
+CAMLprim value* caml_spacetime_indirect_node_hole_ptr
+      (void* callee, value* node_hole, value caller_node)
+{
+  /* Find the address of the node hole for an indirect call to [callee].
+     If [caller_node] is not [Val_unit], it is a pointer to the caller's
+     node, and indicates that this is a tail call site. */
+
+  c_node* c_node;
+  value encoded_callee;
+
+  if (callee == last_indirect_node_hole_ptr_callee
+      && node_hole == last_indirect_node_hole_ptr_node_hole) {
+    return last_indirect_node_hole_ptr_result;
+  }
+
+  last_indirect_node_hole_ptr_callee = callee;
+  last_indirect_node_hole_ptr_node_hole = node_hole;
+
+  encoded_callee = Encode_c_node_pc_for_call(callee);
+
+  while (*node_hole != Val_unit) {
+    Assert(((uintnat) *node_hole) % sizeof(value) == 0);
+
+    c_node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole);
+
+    Assert(c_node != NULL);
+    Assert(caml_spacetime_classify_c_node(c_node) == CALL);
+
+    if (c_node->pc == encoded_callee) {
+      last_indirect_node_hole_ptr_result = &(c_node->data.callee_node);
+      return last_indirect_node_hole_ptr_result;
+    }
+    else {
+      node_hole = &c_node->next;
+    }
+  }
+
+  c_node = allocate_c_node();
+  c_node->pc = encoded_callee;
+
+  if (caller_node != Val_unit) {
+    /* This is a tail call site.
+       Perform the initialization equivalent to that emitted by
+       [Spacetime.code_for_function_prologue] for direct tail call
+       sites. */
+    c_node->data.callee_node = Encode_tail_caller_node(caller_node);
+  }
+
+  *node_hole = caml_spacetime_stored_pointer_of_c_node(c_node);
+
+  Assert(((uintnat) *node_hole) % sizeof(value) == 0);
+  Assert(*node_hole != Val_unit);
+
+  last_indirect_node_hole_ptr_result = &(c_node->data.callee_node);
+
+  return last_indirect_node_hole_ptr_result;
+}
+
+/* Some notes on why caml_call_gc doesn't need a distinguished node.
+   (Remember that thread switches are irrelevant here because each thread
+   has its own trie.)
+
+   caml_call_gc only invokes OCaml functions in the following circumstances:
+   1. running an OCaml finaliser;
+   2. executing an OCaml signal handler.
+   Both of these are done on the finaliser trie.  Furthermore, both of
+   these invocations start via caml_callback; the code in this file for
+   handling that (caml_spacetime_c_to_ocaml) correctly copes with that by
+   attaching a single "caml_start_program" node that can cope with any
+   number of indirect OCaml calls from that point.
+
+   caml_call_gc may also invoke C functions that cause allocation.  All of
+   these (assuming libunwind support is present) will cause a chain of
+   c_node structures to be attached to the trie, starting at the node hole
+   passed to caml_call_gc from OCaml code.  These structures are extensible
+   and can thus accommodate any number of C backtraces leading from
+   caml_call_gc.
+*/
+/* CR-soon mshinwell: it might in fact be the case now that nothing called
+   from caml_call_gc will do any allocation that ends up on the trie.  We
+   can revisit this after the first release. */
+
+static NOINLINE void* find_trie_node_from_libunwind(int for_allocation,
+    uintnat wosize, struct ext_table** cached_frames)
+{
+#ifdef HAS_LIBUNWIND
+  /* Given that [caml_last_return_address] is the most recent call site in
+     OCaml code, and that we are now in C (or other) code called from that
+     site, obtain a backtrace using libunwind and graft the most recent
+     portion (everything back to but not including [caml_last_return_address])
+     onto the trie.  See the important comment below regarding the fact that
+     call site, and not callee, addresses are recorded during this process.
+
+     If [for_allocation] is non-zero, the final node recorded will be for
+     an allocation, and the returned pointer is to the allocation node.
+     Otherwise, no node is recorded for the innermost frame, and the
+     returned pointer is a pointer to the *node hole* where a node for that
+     frame should be attached.
+
+     If [for_allocation] is non-zero then [wosize] must give the size in
+     words, excluding the header, of the value being allocated.
+
+     If [cached_frames != NULL] then:
+     1. If [*cached_frames] is NULL then save the captured backtrace in a
+        newly-allocated table and store the pointer to that table in
+        [*cached_frames];
+     2. Otherwise use [*cached_frames] as the unwinding information.
+     The intention is that when the context is known (e.g. a function such
+     as [caml_make_vect] known to have been directly invoked from OCaml),
+     we can avoid expensive calls to libunwind.
+  */
+
+  unw_cursor_t cur;
+  unw_context_t ctx;
+  int ret;
+  int innermost_frame;
+  int frame;
+  static struct ext_table frames_local;
+  struct ext_table* frames;
+  static int ext_table_initialised = 0;
+  int have_frames_already = 0;
+  value* node_hole;
+  c_node* node = NULL;
+  int initial_table_size = 1000;
+  int must_initialise_node_for_allocation = 0;
+
+  if (!cached_frames) {
+    if (!ext_table_initialised) {
+      caml_ext_table_init(&frames_local, initial_table_size);
+      ext_table_initialised = 1;
+    }
+    else {
+      caml_ext_table_clear(&frames_local, 0);
+    }
+    frames = &frames_local;
+  } else {
+    if (*cached_frames) {
+      frames = *cached_frames;
+      have_frames_already = 1;
+    }
+    else {
+      frames = (struct ext_table*) malloc(sizeof(struct ext_table));
+      if (!frames) {
+        caml_fatal_error("Not enough memory for ext_table allocation");
+      }
+      caml_ext_table_init(frames, initial_table_size);
+      *cached_frames = frames;
+    }
+  }
+
+  if (!have_frames_already) {
+    /* Get the stack backtrace as far as [caml_last_return_address]. */
+
+    ret = unw_getcontext(&ctx);
+    if (ret != UNW_ESUCCESS) {
+      return NULL;
+    }
+
+    ret = unw_init_local(&cur, &ctx);
+    if (ret != UNW_ESUCCESS) {
+      return NULL;
+    }
+
+    while ((ret = unw_step(&cur)) > 0) {
+      unw_word_t ip;
+      unw_get_reg(&cur, UNW_REG_IP, &ip);
+      if (caml_last_return_address == (uintnat) ip) {
+        break;
+      }
+      else {
+        /* Inlined some of [caml_ext_table_add] for speed. */
+        if (frames->size < frames->capacity) {
+          frames->contents[frames->size++] = (void*) ip;
+        } else {
+          caml_ext_table_add(frames, (void*) ip);
+        }
+      }
+    }
+  }
+
+  /* We always need to ignore the frames for:
+      #0  find_trie_node_from_libunwind
+      #1  caml_spacetime_c_to_ocaml
+     Further, if this is not an allocation point, we should not create the
+     node for the current C function that triggered us (i.e. frame #2). */
+  innermost_frame = for_allocation ? 1 : 2;
+
+  if (frames->size - 1 < innermost_frame) {
+    /* Insufficiently many frames (maybe no frames) returned from
+       libunwind; just don't do anything. */
+    return NULL;
+  }
+
+  node_hole = caml_spacetime_trie_node_ptr;
+  /* Note that if [node_hole] is filled, then it must point to a C node,
+     since it is not possible for there to be a call point in an OCaml
+     function that sometimes calls C and sometimes calls OCaml. */
+
+  for (frame = frames->size - 1; frame >= innermost_frame; frame--) {
+    c_node_type expected_type;
+    void* pc = frames->contents[frame];
+    Assert (pc != (void*) caml_last_return_address);
+
+    if (!for_allocation) {
+      expected_type = CALL;
+    }
+    else {
+      expected_type = (frame > innermost_frame ? CALL : ALLOCATION);
+    }
+
+    if (*node_hole == Val_unit) {
+      node = allocate_c_node();
+      /* Note: for CALL nodes, the PC is the program counter at each call
+         site.  We do not store program counter addresses of the start of
+         callees, unlike for OCaml nodes.  This means that some trie nodes
+         will become conflated.  These can be split during post-processing by
+         working out which function each call site was in. */
+      node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc)
+        : Encode_c_node_pc_for_alloc_point(pc));
+      *node_hole = caml_spacetime_stored_pointer_of_c_node(node);
+      if (expected_type == ALLOCATION) {
+        must_initialise_node_for_allocation = 1;
+      }
+    }
+    else {
+      c_node* prev;
+      int found = 0;
+
+      node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole);
+      Assert(node != NULL);
+      Assert(node->next == Val_unit
+        || (((uintnat) (node->next)) % sizeof(value) == 0));
+
+      prev = NULL;
+
+      while (!found && node != NULL) {
+        if (caml_spacetime_classify_c_node(node) == expected_type
+            && pc_inside_c_node_matches(node, pc)) {
+          found = 1;
+        }
+        else {
+          prev = node;
+          node = caml_spacetime_c_node_of_stored_pointer(node->next);
+        }
+      }
+      if (!found) {
+        Assert(prev != NULL);
+        node = allocate_c_node();
+        node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc)
+          : Encode_c_node_pc_for_alloc_point(pc));
+        if (expected_type == ALLOCATION) {
+          must_initialise_node_for_allocation = 1;
+        }
+        prev->next = caml_spacetime_stored_pointer_of_c_node(node);
+      }
+    }
+
+    Assert(node != NULL);
+
+    Assert(caml_spacetime_classify_c_node(node) == expected_type);
+    Assert(pc_inside_c_node_matches(node, pc));
+    node_hole = &node->data.callee_node;
+  }
+
+  if (must_initialise_node_for_allocation) {
+    caml_spacetime_profinfo++;
+    if (caml_spacetime_profinfo > PROFINFO_MASK) {
+      /* Profiling counter overflow. */
+      caml_spacetime_profinfo = PROFINFO_MASK;
+    }
+    node->data.allocation.profinfo =
+      Make_header_with_profinfo(
+        /* "-1" because [c_node] has the GC header as its first
+           element. */
+        offsetof(c_node, data.allocation.count)/sizeof(value) - 1,
+        Infix_tag,
+        Caml_black,
+        caml_spacetime_profinfo);
+    node->data.allocation.count = Val_long(0);
+
+    /* Add the new allocation point into the linked list of all allocation
+       points. */
+    if (caml_all_allocation_points != NULL) {
+      node->data.allocation.next =
+        (value) &caml_all_allocation_points->count;
+    } else {
+      node->data.allocation.next = Val_unit;
+    }
+    caml_all_allocation_points = &node->data.allocation;
+  }
+
+  if (for_allocation) {
+    Assert(caml_spacetime_classify_c_node(node) == ALLOCATION);
+    Assert(caml_spacetime_c_node_of_stored_pointer(node->next) != node);
+    Assert(Profinfo_hd(node->data.allocation.profinfo) > 0);
+    node->data.allocation.count =
+      Val_long(Long_val(node->data.allocation.count) + (1 + wosize));
+  }
+
+  Assert(node->next != (value) NULL);
+
+  return for_allocation ? (void*) node : (void*) node_hole;
+#else
+  return NULL;
+#endif
+}
+
+void caml_spacetime_c_to_ocaml(void* ocaml_entry_point,
+      void* identifying_pc_for_caml_start_program)
+{
+  /* Called in [caml_start_program] and [caml_callback*] when we are about
+     to cross from C into OCaml.  [ocaml_entry_point] is the branch target.
+     This situation is handled by ensuring the presence of a new OCaml node
+     for the callback veneer; the node contains a single indirect call point
+     which accumulates the [ocaml_entry_point]s.
+
+     The layout of the node is described in the "system shape table"; see
+     asmrun/amd64.S.
+  */
+
+  value node;
+
+  /* Update the trie with the current backtrace, as far back as
+     [caml_last_return_address], and leave the node hole pointer at
+     the correct place for attachment of a [caml_start_program] node. */
+
+#ifdef HAS_LIBUNWIND
+  value* node_temp;
+  node_temp = (value*) find_trie_node_from_libunwind(0, 0, NULL);
+  if (node_temp != NULL) {
+    caml_spacetime_trie_node_ptr = node_temp;
+  }
+#endif
+
+  if (*caml_spacetime_trie_node_ptr == Val_unit) {
+    uintnat size_including_header;
+
+    size_including_header =
+      1 /* GC header */ + Node_num_header_words + Indirect_num_fields;
+
+    node = allocate_uninitialized_ocaml_node(size_including_header);
+    Hd_val(node) =
+      Make_header(size_including_header - 1, OCaml_node_tag, Caml_black);
+    Assert((((uintnat) identifying_pc_for_caml_start_program) % 1) == 0);
+    Node_pc(node) = Encode_node_pc(identifying_pc_for_caml_start_program);
+    Tail_link(node) = node;
+    Indirect_pc_linked_list(node, Node_num_header_words) = Val_unit;
+    *caml_spacetime_trie_node_ptr = node;
+  }
+  else {
+    node = *caml_spacetime_trie_node_ptr;
+    /* If there is a node here already, it should never be an initialized
+       (but as yet unused) tail call point, since calls from OCaml into C
+       are never tail calls (and no C -> C call is marked as tail). */
+    Assert(!Is_tail_caller_node_encoded(node));
+  }
+
+  Assert(Is_ocaml_node(node));
+  Assert(Decode_node_pc(Node_pc(node))
+    == identifying_pc_for_caml_start_program);
+  Assert(Tail_link(node) == node);
+  Assert(Wosize_val(node) == Node_num_header_words + Indirect_num_fields);
+
+  /* Search the node to find the node hole corresponding to the indirect
+     call to the OCaml function. */
+  caml_spacetime_trie_node_ptr =
+    caml_spacetime_indirect_node_hole_ptr(
+      ocaml_entry_point,
+      &Indirect_pc_linked_list(node, Node_num_header_words),
+      Val_unit);
+  Assert(*caml_spacetime_trie_node_ptr == Val_unit
+    || Is_ocaml_node(*caml_spacetime_trie_node_ptr));
+}
+
+extern void caml_garbage_collection(void);  /* signals_asm.c */
+extern void caml_array_bound_error(void);  /* fail.c */
+
+CAMLprim uintnat caml_spacetime_generate_profinfo (void* profinfo_words,
+                                                   uintnat index_within_node)
+{
+  /* Called from code that creates a value's header inside an OCaml
+     function. */
+
+  value node;
+  uintnat profinfo;
+
+  caml_spacetime_profinfo++;
+  if (caml_spacetime_profinfo > PROFINFO_MASK) {
+    /* Profiling counter overflow. */
+    caml_spacetime_profinfo = PROFINFO_MASK;
+  }
+  profinfo = caml_spacetime_profinfo;
+
+  /* CR-someday mshinwell: we could always use the [struct allocation_point]
+     overlay instead of the macros now. */
+
+  /* [node] isn't really a node; it points into the middle of
+     one---specifically to the "profinfo" word of an allocation point.
+     It's done like this to avoid re-calculating the place in the node
+     (which already has to be done in the OCaml-generated code run before
+     this function). */
+  node = (value) profinfo_words;
+  Assert(Alloc_point_profinfo(node, 0) == Val_unit);
+
+  /* The profinfo value is stored shifted to reduce the number of
+     instructions required on the OCaml side.  It also enables us to use
+     [Infix_tag] to obtain valid value pointers into the middle of nodes,
+     which is used for the linked list of all allocation points. */
+  profinfo = Make_header_with_profinfo(
+    index_within_node, Infix_tag, Caml_black, profinfo);
+
+  Assert(!Is_block(profinfo));
+  Alloc_point_profinfo(node, 0) = profinfo;
+  /* The count is set to zero by the initialisation when the node was
+     created (see above). */
+  Assert(Alloc_point_count(node, 0) == Val_long(0));
+
+  /* Add the new allocation point into the linked list of all allocation
+     points. */
+  if (caml_all_allocation_points != NULL) {
+    Alloc_point_next_ptr(node, 0) = (value) &caml_all_allocation_points->count;
+  }
+  else {
+    Assert(Alloc_point_next_ptr(node, 0) == Val_unit);
+  }
+  caml_all_allocation_points = (allocation_point*) node;
+
+  return profinfo;
+}
+
+uintnat caml_spacetime_my_profinfo (struct ext_table** cached_frames,
+                                    uintnat wosize)
+{
+  /* Return the profinfo value that should be written into a value's header
+     during an allocation from C.  This may necessitate extending the trie
+     with information obtained from libunwind. */
+
+  c_node* node;
+  uintnat profinfo = 0;
+
+  node = find_trie_node_from_libunwind(1, wosize, cached_frames);
+  if (node != NULL) {
+    profinfo = ((uintnat) (node->data.allocation.profinfo)) >> PROFINFO_SHIFT;
+  }
+
+  return profinfo;  /* N.B. not shifted by PROFINFO_SHIFT */
+}
+
+void caml_spacetime_automatic_snapshot (void)
+{
+  if (automatic_snapshots) {
+    double start_time, end_time;
+    start_time = caml_sys_time_unboxed(Val_unit);
+    if (start_time >= next_snapshot_time) {
+      maybe_reopen_snapshot_channel();
+      caml_spacetime_save_snapshot(snapshot_channel, 0.0, 0);
+      end_time = caml_sys_time_unboxed(Val_unit);
+      next_snapshot_time = end_time + snapshot_interval;
+    }
+  }
+}
+
+CAMLprim value caml_spacetime_save_event_for_automatic_snapshots
+  (value v_event_name)
+{
+  if (automatic_snapshots) {
+    maybe_reopen_snapshot_channel();
+    caml_spacetime_save_event_internal (Val_unit, snapshot_channel,
+                                        v_event_name);
+  }
+  return Val_unit;
+}
+
+void caml_spacetime_automatic_save (void)
+{
+  /* Called from [atexit]. */
+
+  if (automatic_snapshots) {
+    automatic_snapshots = 0;
+    maybe_reopen_snapshot_channel();
+    save_trie(snapshot_channel, 0.0, 0);
+    caml_flush(snapshot_channel);
+    caml_close_channel(snapshot_channel);
+  }
+}
+
+CAMLprim value caml_spacetime_enabled (value v_unit)
+{
+  return Val_true;
+}
+
+CAMLprim value caml_register_channel_for_spacetime (value v_channel)
+{
+  struct channel* channel = Channel(v_channel);
+  channel->flags |= CHANNEL_FLAG_BLOCKING_WRITE;
+  return Val_unit;
+}
+
+#else
+
+/* Functions for when the compiler was not configured with "-spacetime". */
+
+CAMLprim value caml_spacetime_write_magic_number(value v_channel)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_spacetime_enabled (value v_unit)
+{
+  return Val_false;
+}
+
+CAMLprim value caml_spacetime_save_event (value v_time_opt,
+                                          value v_channel,
+                                          value v_event_name)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_spacetime_save_event_for_automatic_snapshots
+  (value v_event_name)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_spacetime_save_trie (value ignored)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_register_channel_for_spacetime (value v_channel)
+{
+  return Val_unit;
+}
+
+#endif

diff --git a/asmrun/spacetime.h b/asmrun/spacetime.h
new file mode 100644 (file)
index 0000000..bb61bb3
--- /dev/null
+++ b/asmrun/spacetime.h
@@ -0,0 +1,191 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2013--2016, Jane Street Group, LLC                         */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_SPACETIME_H
+#define CAML_SPACETIME_H
+
+#include "caml/io.h"
+#include "caml/misc.h"
+#include "caml/stack.h"
+
+/* Runtime support for Spacetime profiling.
+ * This header file is not intended for the casual user.
+ *
+ * The implementation is split into three files:
+ *   1. spacetime.c: core management of the instrumentation;
+ *   2. spacetime_snapshot.c: the taking of heap snapshots;
+ *   3. spacetime_offline.c: functions that are also used when examining
+ *      saved profiling data.
+ */
+
+typedef enum {
+  CALL,
+  ALLOCATION
+} c_node_type;
+
+/* All pointers between nodes point at the word immediately after the
+   GC headers, and everything is traversable using the normal OCaml rules.
+
+   On entry to an OCaml function:
+   If the node hole pointer register has the bottom bit set, then the function
+   is being tail called or called from a self-recursive call site:
+   - If the node hole is empty, the callee must create a new node and link
+     it into the tail chain.  The node hole pointer will point at the tail
+     chain.
+   - Otherwise the node should be used as normal.
+   Otherwise (not a tail call):
+   - If the node hole is empty, the callee must create a new node, but the
+     tail chain is untouched.
+   - Otherwise the node should be used as normal.
+*/
+
+/* Classification of nodes (OCaml or C) with corresponding GC tags. */
+#define OCaml_node_tag 0
+#define C_node_tag 1
+#define Is_ocaml_node(node) (Is_block(node) && Tag_val(node) == OCaml_node_tag)
+#define Is_c_node(node) (Is_block(node) && Tag_val(node) == C_node_tag)
+
+/* The header words are:
+   1. The node program counter.
+   2. The tail link. */
+#define Node_num_header_words 2
+
+/* The "node program counter" at the start of an OCaml node. */
+#define Node_pc(node) (Field(node, 0))
+#define Encode_node_pc(pc) (((value) pc) | 1)
+#define Decode_node_pc(encoded_pc) ((void*) (encoded_pc & ~1))
+
+/* The circular linked list of tail-called functions within OCaml nodes. */
+#define Tail_link(node) (Field(node, 1))
+
+/* The convention for pointers from OCaml nodes to other nodes.  There are
+   two special cases:
+   1. [Val_unit] means "uninitialized", and further, that this is not a
+      tail call point.  (Tail call points are pre-initialized, as in case 2.)
+   2. If the bottom bit is set, and the value is not [Val_unit], this is a
+      tail call point. */
+#define Encode_tail_caller_node(node) ((node) | 1)
+#define Decode_tail_caller_node(node) ((node) & ~1)
+#define Is_tail_caller_node_encoded(node) (((node) & 1) == 1)
+
+/* Allocation points within OCaml nodes.
+   The "profinfo" value looks exactly like a black Infix_tag header.
+   This enables us to point just after it and return such pointer as a valid
+   OCaml value.  (Used for the list of all allocation points.  We could do
+   without this and instead just encode the list pointers as integers, but
+   this would mean that the structure was destroyed on marshalling.  This
+   might not be a great problem since it is intended that the total counts
+   be obtained via snapshots, but it seems neater and easier to use
+   Infix_tag.
+   The "count" is just an OCaml integer giving the total number of words
+   (including headers) allocated at the point.
+   The "pointer to next allocation point" points to the "count" word of the
+   next allocation point in the linked list of all allocation points.
+   There is no special encoding needed by virtue of the [Infix_tag] trick. */
+#define Alloc_point_profinfo(node, offset) (Field(node, offset))
+#define Alloc_point_count(node, offset) (Field(node, offset + 1))
+#define Alloc_point_next_ptr(node, offset) (Field(node, offset + 2))
+
+/* Direct call points (tail or non-tail) within OCaml nodes.
+   They just hold a pointer to the child node.  The call site and callee are
+   both recorded in the shape. */
+#define Direct_callee_node(node,offset) (Field(node, offset))
+#define Encode_call_point_pc(pc) (((value) pc) | 1)
+#define Decode_call_point_pc(pc) ((void*) (((value) pc) & ~((uintnat) 1)))
+
+/* Indirect call points (tail or non-tail) within OCaml nodes.
+   They hold a linked list of (PC upon entry to the callee, pointer to
+   child node) pairs.  The linked list is encoded using C nodes and should
+   be thought of as part of the OCaml node itself. */
+#define Indirect_num_fields 1
+#define Indirect_pc_linked_list(node,offset) (Field(node, offset))
+
+/* Encodings of the program counter value within a C node. */
+#define Encode_c_node_pc_for_call(pc) ((((value) pc) << 2) | 3)
+#define Encode_c_node_pc_for_alloc_point(pc) ((((value) pc) << 2) | 1)
+#define Decode_c_node_pc(pc) ((void*) (((uintnat) (pc)) >> 2))
+
+typedef struct {
+  /* The layout and encoding of this structure must match that of the
+     allocation points within OCaml nodes, so that the linked list
+     traversal across all allocation points works correctly. */
+  value profinfo;  /* encoded using [Infix_tag] (see above) */
+  value count;
+  /* [next] is [Val_unit] for the end of the list.
+     Otherwise it points at the second word of this [allocation_point]
+     structure. */
+  value next;
+} allocation_point;
+
+typedef struct {
+  /* CR-soon mshinwell: delete [gc_header], all the offset arithmetic will
+     then go away */
+  uintnat gc_header;
+  uintnat pc;           /* see above for encodings */
+  union {
+    value callee_node;  /* for CALL */
+    allocation_point allocation;  /* for ALLOCATION */
+  } data;
+  value next;           /* [Val_unit] for the end of the list */
+} c_node; /* CR-soon mshinwell: rename to dynamic_node */
+
+typedef struct shape_table {
+  uint64_t* table;
+  struct shape_table* next;
+} shape_table;
+
+extern uint64_t** caml_spacetime_static_shape_tables;
+extern shape_table* caml_spacetime_dynamic_shape_tables;
+
+typedef struct ext_table* spacetime_unwind_info_cache;
+
+extern value caml_spacetime_trie_root;
+extern value* caml_spacetime_trie_node_ptr;
+extern value* caml_spacetime_finaliser_trie_root;
+
+extern allocation_point* caml_all_allocation_points;
+
+extern void caml_spacetime_initialize(void);
+extern uintnat caml_spacetime_my_profinfo(
+  spacetime_unwind_info_cache*, uintnat);
+extern c_node_type caml_spacetime_classify_c_node(c_node* node);
+extern c_node* caml_spacetime_c_node_of_stored_pointer(value);
+extern c_node* caml_spacetime_c_node_of_stored_pointer_not_null(value);
+extern value caml_spacetime_stored_pointer_of_c_node(c_node* node);
+extern void caml_spacetime_register_thread(value*, value*);
+extern void caml_spacetime_register_shapes(void*);
+extern value caml_spacetime_frame_table(void);
+extern value caml_spacetime_shape_table(void);
+extern void caml_spacetime_save_snapshot (struct channel *chan,
+                                          double time_override,
+                                          int use_time_override);
+extern value caml_spacetime_timestamp(double time_override,
+                                      int use_time_override);
+extern void caml_spacetime_automatic_snapshot (void);
+
+/* For use in runtime functions that are executed from OCaml
+   code, to save the overhead of using libunwind every time. */
+#ifdef WITH_SPACETIME
+#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \
+  do { \
+    static spacetime_unwind_info_cache spacetime_unwind_info = NULL; \
+    profinfo = caml_spacetime_my_profinfo(&spacetime_unwind_info, size); \
+  } \
+  while (0);
+#else
+#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \
+  profinfo = (uintnat) 0;
+#endif
+
+#endif

diff --git a/asmrun/spacetime_offline.c b/asmrun/spacetime_offline.c
new file mode 100644 (file)
index 0000000..221c6a6
--- /dev/null
+++ b/asmrun/spacetime_offline.c
@@ -0,0 +1,228 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2013--2016, Jane Street Group, LLC                         */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+
+#include "caml/alloc.h"
+#include "caml/config.h"
+#include "caml/fail.h"
+#include "caml/gc.h"
+#include "caml/intext.h"
+#include "caml/major_gc.h"
+#include "caml/memory.h"
+#include "caml/minor_gc.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#include "caml/stack.h"
+#include "caml/sys.h"
+#include "spacetime.h"
+
+#include "../config/s.h"
+
+#ifdef ARCH_SIXTYFOUR
+
+/* CR-someday lwhite: The following two definitions are copied from spacetime.c
+   because they are needed here, but must be inlined in spacetime.c
+   for performance. Perhaps a macro or "static inline" would be
+   more appropriate. */
+
+c_node* caml_spacetime_offline_c_node_of_stored_pointer_not_null
+          (value node_stored)
+{
+  Assert(Is_c_node(node_stored));
+  return (c_node*) Hp_val(node_stored);
+}
+
+c_node_type caml_spacetime_offline_classify_c_node(c_node* node)
+{
+  return (node->pc & 2) ? CALL : ALLOCATION;
+}
+
+CAMLprim value caml_spacetime_compare_node(
+      value node1, value node2)
+{
+  Assert(!Is_in_value_area(node1));
+  Assert(!Is_in_value_area(node2));
+
+  if (node1 == node2) {
+    return Val_long(0);
+  }
+  if (node1 < node2) {
+    return Val_long(-1);
+  }
+  return Val_long(1);
+}
+
+CAMLprim value caml_spacetime_unmarshal_trie (value v_channel)
+{
+  return caml_input_value_to_outside_heap(v_channel);
+}
+
+CAMLprim value caml_spacetime_node_num_header_words(value unit)
+{
+  unit = Val_unit;
+  return Val_long(Node_num_header_words);
+}
+
+CAMLprim value caml_spacetime_is_ocaml_node(value node)
+{
+  Assert(Is_ocaml_node(node) || Is_c_node(node));
+  return Val_bool(Is_ocaml_node(node));
+}
+
+CAMLprim value caml_spacetime_ocaml_function_identifier(value node)
+{
+  Assert(Is_ocaml_node(node));
+  return caml_copy_int64((uint64_t) Decode_node_pc(Node_pc(node)));
+}
+
+CAMLprim value caml_spacetime_ocaml_tail_chain(value node)
+{
+  Assert(Is_ocaml_node(node));
+  return Tail_link(node);
+}
+
+CAMLprim value caml_spacetime_classify_direct_call_point
+      (value node, value offset)
+{
+  uintnat field;
+  value callee_node;
+
+  Assert(Is_ocaml_node(node));
+
+  field = Long_val(offset);
+
+  callee_node = Direct_callee_node(node, field);
+  if (!Is_block(callee_node)) {
+    /* An unused call point (may be a tail call point). */
+    return Val_long(0);
+  } else if (Is_ocaml_node(callee_node)) {
+    return Val_long(1);  /* direct call point to OCaml code */
+  } else {
+    return Val_long(2);  /* direct call point to non-OCaml code */
+  }
+}
+
+CAMLprim value caml_spacetime_ocaml_allocation_point_annotation
+      (value node, value offset)
+{
+  uintnat profinfo_shifted;
+  profinfo_shifted = (uintnat) Alloc_point_profinfo(node, Long_val(offset));
+  return Val_long(Profinfo_hd(profinfo_shifted));
+}
+
+CAMLprim value caml_spacetime_ocaml_allocation_point_count
+      (value node, value offset)
+{
+  value count = Alloc_point_count(node, Long_val(offset));
+  Assert(!Is_block(count));
+  return count;
+}
+
+CAMLprim value caml_spacetime_ocaml_direct_call_point_callee_node
+      (value node, value offset)
+{
+  return Direct_callee_node(node, Long_val(offset));
+}
+
+CAMLprim value caml_spacetime_ocaml_indirect_call_point_callees
+      (value node, value offset)
+{
+  value callees = Indirect_pc_linked_list(node, Long_val(offset));
+  Assert(Is_block(callees));
+  Assert(Is_c_node(callees));
+  return callees;
+}
+
+CAMLprim value caml_spacetime_c_node_is_call(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  switch (caml_spacetime_offline_classify_c_node(c_node)) {
+    case CALL: return Val_true;
+    case ALLOCATION: return Val_false;
+  }
+  Assert(0);
+  return Val_unit;  /* silence compiler warning */
+}
+
+CAMLprim value caml_spacetime_c_node_next(value node)
+{
+  c_node* c_node;
+
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  Assert(c_node->next == Val_unit || Is_c_node(c_node->next));
+  return c_node->next;
+}
+
+CAMLprim value caml_spacetime_c_node_call_site(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  return caml_copy_int64((uint64_t) Decode_c_node_pc(c_node->pc));
+}
+
+CAMLprim value caml_spacetime_c_node_callee_node(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  Assert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
+  /* This might be an uninitialised tail call point: for example if an OCaml
+     callee was indirectly called but the callee wasn't instrumented (e.g. a
+     leaf function that doesn't allocate). */
+  if (Is_tail_caller_node_encoded(c_node->data.callee_node)) {
+    return Val_unit;
+  }
+  return c_node->data.callee_node;
+}
+
+CAMLprim value caml_spacetime_c_node_profinfo(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
+  Assert(!Is_block(c_node->data.allocation.profinfo));
+  return Val_long(Profinfo_hd(c_node->data.allocation.profinfo));
+}
+
+CAMLprim value caml_spacetime_c_node_allocation_count(value node)
+{
+  c_node* c_node;
+  Assert(node != (value) NULL);
+  Assert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
+  Assert(!Is_block(c_node->data.allocation.count));
+  return c_node->data.allocation.count;
+}
+
+#endif

diff --git a/asmrun/spacetime_snapshot.c b/asmrun/spacetime_snapshot.c
new file mode 100644 (file)
index 0000000..9c582a8
--- /dev/null
+++ b/asmrun/spacetime_snapshot.c
@@ -0,0 +1,600 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2013--2016, Jane Street Group, LLC                         */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+#include <math.h>
+
+#include "caml/alloc.h"
+#include "caml/backtrace_prim.h"
+#include "caml/config.h"
+#include "caml/custom.h"
+#include "caml/fail.h"
+#include "caml/gc.h"
+#include "caml/gc_ctrl.h"
+#include "caml/intext.h"
+#include "caml/major_gc.h"
+#include "caml/memory.h"
+#include "caml/minor_gc.h"
+#include "caml/misc.h"
+#include "caml/mlvalues.h"
+#include "caml/roots.h"
+#include "caml/signals.h"
+#include "caml/stack.h"
+#include "caml/sys.h"
+#include "spacetime.h"
+
+#ifdef WITH_SPACETIME
+
+/* The following structures must match the type definitions in the
+   [Spacetime] module. */
+
+typedef struct {
+  /* (GC header here.) */
+  value minor_words;
+  value promoted_words;
+  value major_words;
+  value minor_collections;
+  value major_collections;
+  value heap_words;
+  value heap_chunks;
+  value compactions;
+  value top_heap_words;
+} gc_stats;
+
+typedef struct {
+  value profinfo;
+  value num_blocks;
+  value num_words_including_headers;
+} snapshot_entry;
+
+typedef struct {
+  /* (GC header here.) */
+  snapshot_entry entries[0];
+} snapshot_entries;
+
+typedef struct {
+  /* (GC header here.) */
+  value time;
+  value gc_stats;
+  value entries;
+  value words_scanned;
+  value words_scanned_with_profinfo;
+  value total_allocations;
+} snapshot;
+
+typedef struct {
+  uintnat num_blocks;
+  uintnat num_words_including_headers;
+} raw_snapshot_entry;
+
+static value allocate_outside_heap_with_tag(mlsize_t size_in_bytes, tag_t tag)
+{
+  /* CR-soon mshinwell: this function should live somewhere else */
+  header_t* block;
+
+  Assert(size_in_bytes % sizeof(value) == 0);
+  block = caml_stat_alloc(sizeof(header_t) + size_in_bytes);
+  *block = Make_header(size_in_bytes / sizeof(value), tag, Caml_black);
+  return (value) &block[1];
+}
+
+static value allocate_outside_heap(mlsize_t size_in_bytes)
+{
+  Assert(size_in_bytes > 0);
+  return allocate_outside_heap_with_tag(size_in_bytes, 0);
+}
+
+static value take_gc_stats(void)
+{
+  value v_stats;
+  gc_stats* stats;
+
+  v_stats = allocate_outside_heap(sizeof(gc_stats));
+  stats = (gc_stats*) v_stats;
+
+  stats->minor_words = Val_long(caml_stat_minor_words);
+  stats->promoted_words = Val_long(caml_stat_promoted_words);
+  stats->major_words =
+    Val_long(((uintnat) caml_stat_major_words)
+             + ((uintnat) caml_allocated_words));
+  stats->minor_collections = Val_long(caml_stat_minor_collections);
+  stats->major_collections = Val_long(caml_stat_major_collections);
+  stats->heap_words = Val_long(caml_stat_heap_wsz / sizeof(value));
+  stats->heap_chunks = Val_long(caml_stat_heap_chunks);
+  stats->compactions = Val_long(caml_stat_compactions);
+  stats->top_heap_words = Val_long(caml_stat_top_heap_wsz / sizeof(value));
+
+  return v_stats;
+}
+
+static value get_total_allocations(void)
+{
+  value v_total_allocations = Val_unit;
+  allocation_point* total = caml_all_allocation_points;
+
+  while (total != NULL) {
+    value v_total;
+    v_total = allocate_outside_heap_with_tag(3 * sizeof(value), 0);
+
+    /* [v_total] is of type [Raw_spacetime_lib.total_allocations]. */
+    Field(v_total, 0) = Val_long(Profinfo_hd(total->profinfo));
+    Field(v_total, 1) = total->count;
+    Field(v_total, 2) = v_total_allocations;
+    v_total_allocations = v_total;
+
+    Assert (total->next == Val_unit
+      || (Is_block(total->next) && Tag_val(total->next) == Infix_tag));
+    if (total->next == Val_unit) {
+      total = NULL;
+    }
+    else {
+      total = (allocation_point*) Hp_val(total->next);
+    }
+  }
+
+  return v_total_allocations;
+}
+
+static value take_snapshot(double time_override, int use_time_override)
+{
+  value v_snapshot;
+  snapshot* heap_snapshot;
+  value v_entries;
+  snapshot_entries* entries;
+  char* chunk;
+  value gc_stats;
+  uintnat index;
+  uintnat target_index;
+  value v_time;
+  double time;
+  uintnat profinfo;
+  uintnat num_distinct_profinfos;
+  /* Fixed size buffer to avoid needing a hash table: */
+  static raw_snapshot_entry* raw_entries = NULL;
+  uintnat words_scanned = 0;
+  uintnat words_scanned_with_profinfo = 0;
+  value v_total_allocations;
+
+  if (!use_time_override) {
+    time = caml_sys_time_unboxed(Val_unit);
+  }
+  else {
+    time = time_override;
+  }
+
+  gc_stats = take_gc_stats();
+
+  if (raw_entries == NULL) {
+    size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry);
+    raw_entries = caml_stat_alloc(size);
+    memset(raw_entries, '\0', size);
+  } else {
+    size_t size = (PROFINFO_MASK + 1) * sizeof(raw_snapshot_entry);
+    memset(raw_entries, '\0', size);
+  }
+
+  num_distinct_profinfos = 0;
+
+  /* CR-someday mshinwell: consider reintroducing minor heap scanning,
+     properly from roots, which would then give a snapshot function
+     that doesn't do a minor GC.  Although this may not be that important
+     and potentially not worth the effort (it's quite tricky). */
+
+  /* Scan the major heap. */
+  chunk = caml_heap_start;
+  while (chunk != NULL) {
+    char* hp;
+    char* limit;
+
+    hp = chunk;
+    limit = chunk + Chunk_size (chunk);
+
+    while (hp < limit) {
+      header_t hd = Hd_hp (hp);
+      switch (Color_hd(hd)) {
+        case Caml_blue:
+          break;
+
+        default:
+          if (Wosize_hd(hd) > 0) { /* ignore atoms */
+            profinfo = Profinfo_hd(hd);
+            words_scanned += Whsize_hd(hd);
+            if (profinfo > 0 && profinfo < PROFINFO_MASK) {
+              words_scanned_with_profinfo += Whsize_hd(hd);
+              Assert (raw_entries[profinfo].num_blocks >= 0);
+              if (raw_entries[profinfo].num_blocks == 0) {
+                num_distinct_profinfos++;
+              }
+              raw_entries[profinfo].num_blocks++;
+              raw_entries[profinfo].num_words_including_headers +=
+                Whsize_hd(hd);
+            }
+          }
+          break;
+      }
+      hp += Bhsize_hd (hd);
+      Assert (hp <= limit);
+    }
+
+    chunk = Chunk_next (chunk);
+  }
+
+  if (num_distinct_profinfos > 0) {
+    v_entries = allocate_outside_heap(
+      num_distinct_profinfos*sizeof(snapshot_entry));
+    entries = (snapshot_entries*) v_entries;
+    target_index = 0;
+    for (index = 0; index <= PROFINFO_MASK; index++) {
+      Assert(raw_entries[index].num_blocks >= 0);
+      if (raw_entries[index].num_blocks > 0) {
+        Assert(target_index < num_distinct_profinfos);
+        entries->entries[target_index].profinfo = Val_long(index);
+        entries->entries[target_index].num_blocks
+          = Val_long(raw_entries[index].num_blocks);
+        entries->entries[target_index].num_words_including_headers
+          = Val_long(raw_entries[index].num_words_including_headers);
+        target_index++;
+      }
+    }
+  } else {
+    v_entries = Atom(0);
+  }
+
+  Assert(sizeof(double) == sizeof(value));
+  v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
+  Double_field(v_time, 0) = time;
+
+  v_snapshot = allocate_outside_heap(sizeof(snapshot));
+  heap_snapshot = (snapshot*) v_snapshot;
+
+  v_total_allocations = get_total_allocations();
+
+  heap_snapshot->time = v_time;
+  heap_snapshot->gc_stats = gc_stats;
+  heap_snapshot->entries = v_entries;
+  heap_snapshot->words_scanned
+    = Val_long(words_scanned);
+  heap_snapshot->words_scanned_with_profinfo
+    = Val_long(words_scanned_with_profinfo);
+  heap_snapshot->total_allocations = v_total_allocations;
+
+  return v_snapshot;
+}
+
+void caml_spacetime_save_snapshot (struct channel *chan, double time_override,
+                                   int use_time_override)
+{
+  value v_snapshot;
+  value v_total_allocations;
+  snapshot* heap_snapshot;
+
+  Lock(chan);
+
+  v_snapshot = take_snapshot(time_override, use_time_override);
+
+  caml_output_val(chan, Val_long(0), Val_long(0));
+
+  caml_extern_allow_out_of_heap = 1;
+  caml_output_val(chan, v_snapshot, Val_long(0));
+  caml_extern_allow_out_of_heap = 0;
+
+  Unlock(chan);
+
+  heap_snapshot = (snapshot*) v_snapshot;
+  caml_stat_free(Hp_val(heap_snapshot->time));
+  caml_stat_free(Hp_val(heap_snapshot->gc_stats));
+  if (Wosize_val(heap_snapshot->entries) > 0) {
+    caml_stat_free(Hp_val(heap_snapshot->entries));
+  }
+  v_total_allocations = heap_snapshot->total_allocations;
+  while (v_total_allocations != Val_unit) {
+    value next = Field(v_total_allocations, 2);
+    caml_stat_free(Hp_val(v_total_allocations));
+    v_total_allocations = next;
+  }
+
+  caml_stat_free(Hp_val(v_snapshot));
+}
+
+CAMLprim value caml_spacetime_take_snapshot(value v_time_opt, value v_channel)
+{
+  struct channel * channel = Channel(v_channel);
+  double time_override = 0.0;
+  int use_time_override = 0;
+
+  if (Is_block(v_time_opt)) {
+    time_override = Double_field(Field(v_time_opt, 0), 0);
+    use_time_override = 1;
+  }
+
+  caml_spacetime_save_snapshot(channel, time_override, use_time_override);
+
+  return Val_unit;
+}
+
+extern struct custom_operations caml_int64_ops;  /* ints.c */
+
+static value
+allocate_int64_outside_heap(uint64_t i)
+{
+  value v;
+
+  v = allocate_outside_heap_with_tag(2 * sizeof(value), Custom_tag);
+  Custom_ops_val(v) = &caml_int64_ops;
+  Int64_val(v) = i;
+
+  return v;
+}
+
+static value
+copy_string_outside_heap(char const *s)
+{
+  int len;
+  mlsize_t wosize, offset_index;
+  value result;
+
+  len = strlen(s);
+  wosize = (len + sizeof (value)) / sizeof (value);
+  result = allocate_outside_heap_with_tag(wosize * sizeof(value), String_tag);
+
+  Field (result, wosize - 1) = 0;
+  offset_index = Bsize_wsize (wosize) - 1;
+  Byte (result, offset_index) = offset_index - len;
+  memmove(String_val(result), s, len);
+
+  return result;
+}
+
+static value
+allocate_loc_outside_heap(struct caml_loc_info li)
+{
+  value result;
+
+  if (li.loc_valid) {
+    result = allocate_outside_heap_with_tag(5 * sizeof(value), 0);
+    Field(result, 0) = Val_bool(li.loc_is_raise);
+    Field(result, 1) = copy_string_outside_heap(li.loc_filename);
+    Field(result, 2) = Val_int(li.loc_lnum);
+    Field(result, 3) = Val_int(li.loc_startchr);
+    Field(result, 4) = Val_int(li.loc_endchr);
+  } else {
+    result = allocate_outside_heap_with_tag(sizeof(value), 1);
+    Field(result, 0) = Val_bool(li.loc_is_raise);
+  }
+
+  return result;
+}
+
+value caml_spacetime_timestamp(double time_override, int use_time_override)
+{
+  double time;
+  value v_time;
+
+  if (!use_time_override) {
+    time = caml_sys_time_unboxed(Val_unit);
+  }
+  else {
+    time = time_override;
+  }
+
+  v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
+  Double_field(v_time, 0) = time;
+
+  return v_time;
+}
+
+value caml_spacetime_frame_table(void)
+{
+  /* Flatten the frame table into a single associative list. */
+
+  value list = Val_long(0);  /* the empty list */
+  uintnat i;
+
+  if (!caml_debug_info_available()) {
+    return list;
+  }
+
+  if (caml_frame_descriptors == NULL) {
+    caml_init_frame_descriptors();
+  }
+
+  for (i = 0; i <= caml_frame_descriptors_mask; i++) {
+    frame_descr* descr = caml_frame_descriptors[i];
+    if (descr != NULL) {
+      value location, return_address, pair, new_list_element, location_list;
+      struct caml_loc_info li;
+      debuginfo dbg;
+      if (descr->frame_size != 0xffff) {
+        dbg = caml_debuginfo_extract(descr);
+        if (dbg != NULL) {
+          location_list = Val_unit;
+          while (dbg != NULL) {
+            value list_element;
+
+            caml_debuginfo_location(dbg, &li);
+            location = allocate_loc_outside_heap(li);
+
+            list_element =
+              allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
+            Field(list_element, 0) = location;
+            Field(list_element, 1) = location_list;
+            location_list = list_element;
+
+            dbg = caml_debuginfo_next(dbg);
+          }
+
+          return_address = allocate_int64_outside_heap(descr->retaddr);
+          pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0);
+          Field(pair, 0) = return_address;
+          Field(pair, 1) = location_list;
+
+          new_list_element =
+            allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
+          Field(new_list_element, 0) = pair;
+          Field(new_list_element, 1) = list;
+          list = new_list_element;
+        }
+      }
+    }
+  }
+
+  return list;
+}
+
+static void add_unit_to_shape_table(uint64_t *unit_table, value *list)
+{
+  /* This function reverses the order of the lists giving the layout of each
+     node; however, spacetime_profiling.ml ensures they are emitted in
+     reverse order, so at the end of it all they're not reversed. */
+
+  uint64_t* ptr = unit_table;
+
+  while (*ptr != (uint64_t) 0) {
+    value new_list_element, pair, function_address, layout;
+
+    function_address =
+      allocate_int64_outside_heap(*ptr++);
+
+    layout = Val_long(0);  /* the empty list */
+    while (*ptr != (uint64_t) 0) {
+      int tag;
+      int stored_tag;
+      value part_of_shape;
+      value new_part_list_element;
+      value location;
+      int has_extra_argument = 0;
+
+      stored_tag = *ptr++;
+      /* CR-soon mshinwell: share with emit.mlp */
+      switch (stored_tag) {
+        case 1:  /* direct call to given location */
+          tag = 0;
+          has_extra_argument = 1;  /* the address of the callee */
+          break;
+
+        case 2:  /* indirect call to given location */
+          tag = 1;
+          break;
+
+        case 3:  /* allocation at given location */
+          tag = 2;
+          break;
+
+        default:
+          Assert(0);
+          abort();  /* silence compiler warning */
+      }
+
+      location = allocate_int64_outside_heap(*ptr++);
+
+      part_of_shape = allocate_outside_heap_with_tag(
+        sizeof(value) * (has_extra_argument ? 2 : 1), tag);
+      Field(part_of_shape, 0) = location;
+      if (has_extra_argument) {
+        Field(part_of_shape, 1) =
+          allocate_int64_outside_heap(*ptr++);
+      }
+
+      new_part_list_element =
+        allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
+      Field(new_part_list_element, 0) = part_of_shape;
+      Field(new_part_list_element, 1) = layout;
+      layout = new_part_list_element;
+    }
+
+    pair = allocate_outside_heap_with_tag(2 * sizeof(value), 0);
+    Field(pair, 0) = function_address;
+    Field(pair, 1) = layout;
+
+    new_list_element =
+      allocate_outside_heap_with_tag(2 * sizeof(value), 0 /* (::) */);
+    Field(new_list_element, 0) = pair;
+    Field(new_list_element, 1) = *list;
+    *list = new_list_element;
+
+    ptr++;
+  }
+}
+
+value caml_spacetime_shape_table(void)
+{
+  value list;
+  uint64_t* unit_table;
+  shape_table *dynamic_table;
+  uint64_t** static_table;
+
+  /* Flatten the hierarchy of shape tables into a single associative list
+     mapping from function symbols to node layouts.  The node layouts are
+     themselves lists. */
+
+  list = Val_long(0);  /* the empty list */
+
+  /* Add static shape tables */
+  static_table = caml_spacetime_static_shape_tables;
+  while (*static_table != (uint64_t) 0) {
+    unit_table = *static_table++;
+    add_unit_to_shape_table(unit_table, &list);
+  }
+
+  /* Add dynamic shape tables */
+  dynamic_table = caml_spacetime_dynamic_shape_tables;
+
+  while (dynamic_table != NULL) {
+    unit_table = dynamic_table->table;
+    add_unit_to_shape_table(unit_table, &list);
+    dynamic_table = dynamic_table->next;
+  }
+
+  return list;
+}
+
+#else
+
+static value spacetime_disabled()
+{
+  caml_failwith("Spacetime profiling not enabled");
+  Assert(0);  /* unreachable */
+}
+
+CAMLprim value caml_spacetime_take_snapshot(value ignored)
+{
+  return Val_unit;
+}
+
+CAMLprim value caml_spacetime_marshal_frame_table ()
+{
+  return spacetime_disabled();
+}
+
+CAMLprim value caml_spacetime_frame_table ()
+{
+  return spacetime_disabled();
+}
+
+CAMLprim value caml_spacetime_marshal_shape_table ()
+{
+  return spacetime_disabled();
+}
+
+CAMLprim value caml_spacetime_shape_table ()
+{
+  return spacetime_disabled();
+}
+
+#endif

diff --git a/asmrun/stack.h b/asmrun/stack.h
deleted file mode 100644 (file)
index 8556b33..0000000
--- a/asmrun/stack.h
+++ /dev/null
@@ -1,119 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 1996 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/* Machine-dependent interface with the asm code */
-
-#ifndef CAML_STACK_H
-#define CAML_STACK_H
-
-/* Macros to access the stack frame */
-
-#ifdef TARGET_sparc
-#define Saved_return_address(sp) *((intnat *)((sp) + 92))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 104))
-#endif
-
-#ifdef TARGET_i386
-#define Saved_return_address(sp) *((intnat *)((sp) - 4))
-#ifndef SYS_win32
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#else
-#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
-#endif
-#endif
-
-#ifdef TARGET_power
-#if defined(MODEL_ppc)
-#define Saved_return_address(sp) *((intnat *)((sp) - 4))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#elif defined(MODEL_ppc64)
-#define Saved_return_address(sp) *((intnat *)((sp) + 16))
-#define Callback_link(sp) ((struct caml_context *)((sp) + (48 + 32)))
-#elif defined(MODEL_ppc64le)
-#define Saved_return_address(sp) *((intnat *)((sp) + 16))
-#define Callback_link(sp) ((struct caml_context *)((sp) + (32 + 32)))
-#else
-#error "TARGET_power: wrong MODEL"
-#endif
-#define Already_scanned(sp, retaddr) ((retaddr) & 1)
-#define Mask_already_scanned(retaddr) ((retaddr) & ~1)
-#define Mark_scanned(sp, retaddr) Saved_return_address(sp) = (retaddr) | 1
-#endif
-
-#ifdef TARGET_s390x
-#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR))
-#define Trap_frame_size 16
-#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size))
-#endif
-
-#ifdef TARGET_arm
-#define Saved_return_address(sp) *((intnat *)((sp) - 4))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
-#endif
-
-#ifdef TARGET_amd64
-#define Saved_return_address(sp) *((intnat *)((sp) - 8))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#endif
-
-#ifdef TARGET_arm64
-#define Saved_return_address(sp) *((intnat *)((sp) - 8))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#endif
-
-/* Structure of OCaml callback contexts */
-
-struct caml_context {
-  char * bottom_of_stack;       /* beginning of OCaml stack chunk */
-  uintnat last_retaddr;         /* last return address in OCaml code */
-  value * gc_regs;              /* pointer to register block */
-};
-
-/* Structure of frame descriptors */
-
-typedef struct {
-  uintnat retaddr;
-  unsigned short frame_size;
-  unsigned short num_live;
-  unsigned short live_ofs[1];
-} frame_descr;
-
-/* Hash table of frame descriptors */
-
-extern frame_descr ** caml_frame_descriptors;
-extern int caml_frame_descriptors_mask;
-
-#define Hash_retaddr(addr) \
-  (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask)
-
-extern void caml_init_frame_descriptors(void);
-extern void caml_register_frametable(intnat *);
-extern void caml_unregister_frametable(intnat *);
-extern void caml_register_dyn_global(void *);
-
-extern uintnat caml_stack_usage (void);
-extern uintnat (*caml_stack_usage_hook)(void);
-
-/* Declaration of variables used in the asm code */
-extern char * caml_top_of_stack;
-extern char * caml_bottom_of_stack;
-extern uintnat caml_last_return_address;
-extern value * caml_gc_regs;
-extern char * caml_exception_pointer;
-extern value * caml_globals[];
-extern intnat caml_globals_inited;
-extern intnat * caml_frametable[];
-
-#endif /* CAML_STACK_H */

diff --git a/asmrun/startup.c b/asmrun/startup.c
index da61ffcde057d168d44a761af282f5de0347ce52..ccf87d02144b029c37fecbeb37089e804f1a5cdc 100644 (file)
--- a/asmrun/startup.c
+++ b/asmrun/startup.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Start-up code */
 
 #include <stdio.h>
@@ -31,9 +33,12 @@
 #include "caml/mlvalues.h"
 #include "caml/osdeps.h"
 #include "caml/printexc.h"
-#include "stack.h"
+#include "caml/stack.h"
 #include "caml/startup_aux.h"
 #include "caml/sys.h"
+#ifdef WITH_SPACETIME
+#include "spacetime.h"
+#endif
 #ifdef HAS_UI
 #include "caml/ui.h"
 #endif
@@ -88,14 +93,13 @@ extern value caml_start_program (void);
 extern void caml_init_ieee_floats (void);
 extern void caml_init_signals (void);
 
-#ifdef _MSC_VER
+#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
 
 /* PR 4887: avoid crash box of windows runtime on some system calls */
 extern void caml_install_invalid_parameter_handler();
 
 #endif
 
-
 void caml_main(char **argv)
 {
   char * exe_name;
@@ -103,9 +107,12 @@ void caml_main(char **argv)
   value res;
   char tos;
 
+#ifdef WITH_SPACETIME
+  caml_spacetime_initialize();
+#endif
   caml_init_frame_descriptors();
   caml_init_ieee_floats();
-#ifdef _MSC_VER
+#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
   caml_install_invalid_parameter_handler();
 #endif
   caml_init_custom_operations();

diff --git a/boot/ocamlc b/boot/ocamlc
index 6ec07c9e3a4c9252ccbb36d466ec4c71b35f9d08..0c31cda09d709fa2c9ad4d2ef22b83be88379b8b 100755 (executable)
Binary files a/boot/ocamlc and b/boot/ocamlc differ

diff --git a/boot/ocamldep b/boot/ocamldep
index ea6697ccd654751d8bb83eb3ec162654dfac5703..eacfcf04200dd699ae73276c2cfa33ceb120eb52 100755 (executable)
Binary files a/boot/ocamldep and b/boot/ocamldep differ

diff --git a/boot/ocamllex b/boot/ocamllex
index 78a36bd7f3a9da33997af3a604e3f3470a6bbc47..0e9b1b4c141b86afb5b678e58a1e02f169f4caa0 100755 (executable)
Binary files a/boot/ocamllex and b/boot/ocamllex differ

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index 806c22cb5361d0133af4bc8403b28db0ea188b73..79384c1f070651564cb304ebf0e3776e3507d48a 100644 (file)
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -136,38 +136,41 @@ type rhs_kind =
 
 let rec check_recordwith_updates id e =
   match e with
-  | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _]), cont)
+  | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _], _), cont)
       -> id2 = id && check_recordwith_updates id cont
   | Lvar id2 -> id2 = id
   | _ -> false
 ;;
 
 let rec size_of_lambda = function
-  | Lfunction{kind; params; body} as funct ->
+  | Lfunction{params} as funct ->
       RHS_function (1 + IdentSet.cardinal(free_variables funct),
                     List.length params)
-  | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body)
+  | Llet (Strict, _k, id, Lprim (Pduprecord (kind, size), _, _), body)
     when check_recordwith_updates id body ->
       begin match kind with
       | Record_regular | Record_inlined _ -> RHS_block size
+      | Record_unboxed _ -> assert false
       | Record_float -> RHS_floatblock size
       | Record_extension -> RHS_block (size + 1)
       end
-  | Llet(str, id, arg, body) -> size_of_lambda body
-  | Lletrec(bindings, body) -> size_of_lambda body
-  | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args)
-  | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args) ->
+  | Llet(_str, _k, _id, _arg, body) -> size_of_lambda body
+  | Lletrec(_bindings, body) -> size_of_lambda body
+  | Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args)
+  | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) ->
       RHS_block (List.length args)
-  | Lprim (Pmakearray (Pfloatarray, _), args) ->
+  | Lprim (Pmakearray (Pfloatarray, _), args, _) ->
       RHS_floatblock (List.length args)
-  | Lprim (Pmakearray (Pgenarray, _), args) -> assert false
-  | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) ->
+  | Lprim (Pmakearray (Pgenarray, _), _, _) -> assert false
+  | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _, _) ->
       RHS_block size
-  | Lprim (Pduprecord (Record_extension, size), args) ->
+  | Lprim (Pduprecord (Record_unboxed _, _), _, _) ->
+      assert false
+  | Lprim (Pduprecord (Record_extension, size), _, _) ->
       RHS_block (size + 1)
-  | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size
+  | Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size
   | Levent (lam, _) -> size_of_lambda lam
-  | Lsequence (lam, lam') -> size_of_lambda lam'
+  | Lsequence (_lam, lam') -> size_of_lambda lam'
   | _ -> RHS_nonrec
 
 (**** Merging consecutive events ****)
@@ -310,9 +313,9 @@ let comp_primitive p args =
     Pgetglobal id -> Kgetglobal id
   | Psetglobal id -> Ksetglobal id
   | Pintcomp cmp -> Kintcomp cmp
-  | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag)
+  | Pmakeblock(tag, _mut, _) -> Kmakeblock(List.length args, tag)
   | Pfield n -> Kgetfield n
-  | Psetfield(n, ptr, _init) -> Ksetfield n
+  | Psetfield(n, _ptr, _init) -> Ksetfield n
   | Pfloatfield n -> Kgetfloatfield n
   | Psetfloatfield (n, _init) -> Ksetfloatfield n
   | Pduprecord _ -> Kccall("caml_obj_dup", 1)
@@ -321,8 +324,8 @@ let comp_primitive p args =
   | Paddint -> Kaddint
   | Psubint -> Ksubint
   | Pmulint -> Kmulint
-  | Pdivint -> Kdivint
-  | Pmodint -> Kmodint
+  | Pdivint _ -> Kdivint
+  | Pmodint _ -> Kmodint
   | Pandint -> Kandint
   | Porint -> Korint
   | Pxorint -> Kxorint
@@ -346,17 +349,19 @@ let comp_primitive p args =
   | Pfloatcomp Cle -> Kccall("caml_le_float", 2)
   | Pfloatcomp Cge -> Kccall("caml_ge_float", 2)
   | Pstringlength -> Kccall("caml_ml_string_length", 1)
+  | Pbyteslength -> Kccall("caml_ml_bytes_length", 1)
   | Pstringrefs -> Kccall("caml_string_get", 2)
-  | Pstringsets -> Kccall("caml_string_set", 3)
-  | Pstringrefu -> Kgetstringchar
-  | Pstringsetu -> Ksetstringchar
+  | Pbytesrefs -> Kccall("caml_bytes_get", 2)
+  | Pbytessets -> Kccall("caml_bytes_set", 3)
+  | Pstringrefu | Pbytesrefu -> Kgetstringchar
+  | Pbytessetu -> Ksetstringchar
   | Pstring_load_16(_) -> Kccall("caml_string_get16", 2)
   | Pstring_load_32(_) -> Kccall("caml_string_get32", 2)
   | Pstring_load_64(_) -> Kccall("caml_string_get64", 2)
   | Pstring_set_16(_) -> Kccall("caml_string_set16", 3)
   | Pstring_set_32(_) -> Kccall("caml_string_set32", 3)
   | Pstring_set_64(_) -> Kccall("caml_string_set64", 3)
-  | Parraylength kind -> Kvectlength
+  | Parraylength _ -> Kvectlength
   | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2)
   | Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2)
   | Parrayrefs _ -> Kccall("caml_array_get_addr", 2)
@@ -377,7 +382,8 @@ let comp_primitive p args =
        | Max_wosize -> "max_wosize"
        | Ostype_unix -> "ostype_unix"
        | Ostype_win32 -> "ostype_win32"
-       | Ostype_cygwin -> "ostype_cygwin" in
+       | Ostype_cygwin -> "ostype_cygwin"
+       | Backend_type -> "backend_type" in
      Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
   | Pisint -> Kisint
   | Pisout -> Kisout
@@ -394,20 +400,20 @@ let comp_primitive p args =
   | Paddbint bi -> comp_bint_primitive bi "add" args
   | Psubbint bi -> comp_bint_primitive bi "sub" args
   | Pmulbint bi -> comp_bint_primitive bi "mul" args
-  | Pdivbint bi -> comp_bint_primitive bi "div" args
-  | Pmodbint bi -> comp_bint_primitive bi "mod" args
+  | Pdivbint { size = bi } -> comp_bint_primitive bi "div" args
+  | Pmodbint { size = bi } -> comp_bint_primitive bi "mod" args
   | Pandbint bi -> comp_bint_primitive bi "and" args
   | Porbint bi -> comp_bint_primitive bi "or" args
   | Pxorbint bi -> comp_bint_primitive bi "xor" args
   | Plslbint bi -> comp_bint_primitive bi "shift_left" args
   | Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args
   | Pasrbint bi -> comp_bint_primitive bi "shift_right" args
-  | Pbintcomp(bi, Ceq) -> Kccall("caml_equal", 2)
-  | Pbintcomp(bi, Cneq) -> Kccall("caml_notequal", 2)
-  | Pbintcomp(bi, Clt) -> Kccall("caml_lessthan", 2)
-  | Pbintcomp(bi, Cgt) -> Kccall("caml_greaterthan", 2)
-  | Pbintcomp(bi, Cle) -> Kccall("caml_lessequal", 2)
-  | Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2)
+  | Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2)
+  | Pbintcomp(_, Cneq) -> Kccall("caml_notequal", 2)
+  | Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2)
+  | Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2)
+  | Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2)
+  | Pbintcomp(_, Cge) -> Kccall("caml_greaterequal", 2)
   | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1)
   | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2)
   | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ string_of_int n, 1)
@@ -497,7 +503,7 @@ let rec comp_expr env exp sz cont =
           comp_args env args' (sz + 3)
             (getmethod :: Kapply nargs :: cont1)
         end
-  | Lfunction{kind; params; body} -> (* assume kind = Curried *)
+  | Lfunction{params; body} -> (* assume kind = Curried *)
       let lbl = new_label() in
       let fv = IdentSet.elements(free_variables exp) in
       let to_compile =
@@ -506,7 +512,7 @@ let rec comp_expr env exp sz cont =
       Stack.push to_compile functions_to_compile;
       comp_args env (List.map (fun n -> Lvar n) fv) sz
         (Kclosure(lbl, List.length fv) :: cont)
-  | Llet(str, id, arg, body) ->
+  | Llet(_str, _k, id, arg, body) ->
       comp_expr env arg sz
         (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
           (add_pop 1 cont))
@@ -517,10 +523,10 @@ let rec comp_expr env exp sz cont =
         (* let rec of functions *)
         let fv =
           IdentSet.elements (free_variables (Lletrec(decl, lambda_unit))) in
-        let rec_idents = List.map (fun (id, lam) -> id) decl in
+        let rec_idents = List.map (fun (id, _lam) -> id) decl in
         let rec comp_fun pos = function
             [] -> []
-          | (id, Lfunction{kind; params; body}) :: rem ->
+          | (_id, Lfunction{params; body}) :: rem ->
               let lbl = new_label() in
               let to_compile =
                 { params = params; body = body; label = lbl; free_vars = fv;
@@ -538,49 +544,50 @@ let rec comp_expr env exp sz cont =
           List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in
         let rec comp_init new_env sz = function
           | [] -> comp_nonrec new_env sz ndecl decl_size
-          | (id, exp, RHS_floatblock blocksize) :: rem ->
+          | (id, _exp, RHS_floatblock blocksize) :: rem ->
               Kconst(Const_base(Const_int blocksize)) ::
               Kccall("caml_alloc_dummy_float", 1) :: Kpush ::
               comp_init (add_var id (sz+1) new_env) (sz+1) rem
-          | (id, exp, RHS_block blocksize) :: rem ->
+          | (id, _exp, RHS_block blocksize) :: rem ->
               Kconst(Const_base(Const_int blocksize)) ::
               Kccall("caml_alloc_dummy", 1) :: Kpush ::
               comp_init (add_var id (sz+1) new_env) (sz+1) rem
-          | (id, exp, RHS_function (blocksize,arity)) :: rem ->
+          | (id, _exp, RHS_function (blocksize,arity)) :: rem ->
               Kconst(Const_base(Const_int arity)) ::
               Kpush ::
               Kconst(Const_base(Const_int blocksize)) ::
               Kccall("caml_alloc_dummy_function", 2) :: Kpush ::
               comp_init (add_var id (sz+1) new_env) (sz+1) rem
-          | (id, exp, RHS_nonrec) :: rem ->
+          | (id, _exp, RHS_nonrec) :: rem ->
               Kconst(Const_base(Const_int 0)) :: Kpush ::
               comp_init (add_var id (sz+1) new_env) (sz+1) rem
         and comp_nonrec new_env sz i = function
           | [] -> comp_rec new_env sz ndecl decl_size
-          | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
+          | (_id, _exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
             :: rem ->
               comp_nonrec new_env sz (i-1) rem
-          | (id, exp, RHS_nonrec) :: rem ->
+          | (_id, exp, RHS_nonrec) :: rem ->
               comp_expr new_env exp sz
                 (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem)
         and comp_rec new_env sz i = function
           | [] -> comp_expr new_env body sz (add_pop ndecl cont)
-          | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
+          | (_id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _))
             :: rem ->
               comp_expr new_env exp sz
                 (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) ::
                  comp_rec new_env sz (i-1) rem)
-          | (id, exp, RHS_nonrec) :: rem ->
+          | (_id, _exp, RHS_nonrec) :: rem ->
               comp_rec new_env sz (i-1) rem
         in
         comp_init env sz decl_size
       end
-  | Lprim((Pidentity | Popaque), [arg]) ->
+  | Lprim((Pidentity | Popaque | Pbytes_to_string | Pbytes_of_string), [arg], _)
+    ->
       comp_expr env arg sz cont
-  | Lprim(Pignore, [arg]) ->
+  | Lprim(Pignore, [arg], _) ->
       comp_expr env arg sz (add_const_unit cont)
-  | Lprim(Pdirapply loc, [func;arg])
-  | Lprim(Prevapply loc, [arg;func]) ->
+  | Lprim(Pdirapply, [func;arg], loc)
+  | Lprim(Prevapply, [arg;func], loc) ->
       let exp = Lapply{ap_should_be_tailcall=false;
                        ap_loc=loc;
                        ap_func=func;
@@ -588,14 +595,14 @@ let rec comp_expr env exp sz cont =
                        ap_inlined=Default_inline;
                        ap_specialised=Default_specialise} in
       comp_expr env exp sz cont
-  | Lprim(Pnot, [arg]) ->
+  | Lprim(Pnot, [arg], _) ->
       let newcont =
         match cont with
           Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1
         | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1
         | _ -> Kboolnot :: cont in
       comp_expr env arg sz newcont
-  | Lprim(Psequand, [exp1; exp2]) ->
+  | Lprim(Psequand, [exp1; exp2], _) ->
       begin match cont with
         Kbranchifnot lbl :: _ ->
           comp_expr env exp1 sz (Kbranchifnot lbl ::
@@ -609,7 +616,7 @@ let rec comp_expr env exp sz cont =
           comp_expr env exp1 sz (Kstrictbranchifnot lbl ::
             comp_expr env exp2 sz cont1)
       end
-  | Lprim(Psequor, [exp1; exp2]) ->
+  | Lprim(Psequor, [exp1; exp2], _) ->
       begin match cont with
         Kbranchif lbl :: _ ->
           comp_expr env exp1 sz (Kbranchif lbl ::
@@ -623,21 +630,21 @@ let rec comp_expr env exp sz cont =
           comp_expr env exp1 sz (Kstrictbranchif lbl ::
             comp_expr env exp2 sz cont1)
       end
-  | Lprim(Praise k, [arg]) ->
+  | Lprim(Praise k, [arg], _) ->
       comp_expr env arg sz (Kraise k :: discard_dead_code cont)
-  | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))])
+  | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))], _)
     when is_immed n ->
       comp_expr env arg sz (Koffsetint n :: cont)
-  | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))])
+  | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))], _)
     when is_immed (-n) ->
       comp_expr env arg sz (Koffsetint (-n) :: cont)
-  | Lprim (Poffsetint n, [arg])
+  | Lprim (Poffsetint n, [arg], _)
     when not (is_immed n) ->
       comp_expr env arg sz
         (Kpush::
          Kconst (Const_base (Const_int n))::
          Kaddint::cont)
-  | Lprim(Pmakearray (kind, _), args) ->
+  | Lprim(Pmakearray (kind, _), args, _) ->
       begin match kind with
         Pintarray | Paddrarray ->
           comp_args env args sz (Kmakeblock(List.length args, 0) :: cont)
@@ -650,22 +657,23 @@ let rec comp_expr env exp sz cont =
                  (Kmakeblock(List.length args, 0) ::
                   Kccall("caml_make_array", 1) :: cont)
       end
-  | Lprim (Pduparray (kind, mutability), [Lprim (Pmakearray (kind',_),args)]) ->
+  | Lprim (Pduparray (kind, mutability),
+           [Lprim (Pmakearray (kind',_),args,_)], loc) ->
       assert (kind = kind');
-      comp_expr env (Lprim (Pmakearray (kind, mutability), args)) sz cont
-  | Lprim (Pduparray _, [arg]) ->
+      comp_expr env (Lprim (Pmakearray (kind, mutability), args, loc)) sz cont
+  | Lprim (Pduparray _, [arg], loc) ->
       let prim_obj_dup =
         Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
       in
-      comp_expr env (Lprim (Pccall prim_obj_dup, [arg])) sz cont
-  | Lprim (Pduparray _, _) ->
+      comp_expr env (Lprim (Pccall prim_obj_dup, [arg], loc)) sz cont
+  | Lprim (Pduparray _, _, _) ->
       Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg"
 (* Integer first for enabling futher optimization (cf. emitcode.ml)  *)
-  | Lprim (Pintcomp c, [arg ; (Lconst _ as k)]) ->
+  | Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) ->
       let p = Pintcomp (commute_comparison c)
       and args = [k ; arg] in
       comp_args env args sz (comp_primitive p args :: cont)
-  | Lprim(p, args) ->
+  | Lprim(p, args, _) ->
       comp_args env args sz (comp_primitive p args :: cont)
   | Lstaticcatch (body, (i, vars) , handler) ->
       let nvars = List.length vars in
@@ -791,8 +799,8 @@ let rec comp_expr env exp sz cont =
         lbl_consts.(i) <- lbls.(act_consts.(i))
       done;
       comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
-  | Lstringswitch (arg,sw,d) ->
-      comp_expr env (Matching.expand_stringswitch arg sw d) sz cont
+  | Lstringswitch (arg,sw,d,loc) ->
+      comp_expr env (Matching.expand_stringswitch loc arg sw d) sz cont
   | Lassign(id, expr) ->
       begin try
         let pos = Ident.find_same id env.ce_stack in

diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index e77920b6df70345bc5584f3baef6f78557da7a2e..660c1eaaa22ae4eda23d66d650e882358ff6e0e9 100644 (file)
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -29,6 +29,7 @@ type error =
   | File_exists of string
   | Cannot_open_dll of string
   | Not_compatible_32
+  | Required_module_unavailable of string
 
 exception Error of error
 
@@ -89,19 +90,26 @@ module IdentSet = Lambda.IdentSet
 
 let missing_globals = ref IdentSet.empty
 
-let is_required (rel, pos) =
+let is_required (rel, _pos) =
   match rel with
     Reloc_setglobal id ->
       IdentSet.mem id !missing_globals
   | _ -> false
 
-let add_required (rel, pos) =
-  match rel with
-    Reloc_getglobal id ->
-      missing_globals := IdentSet.add id !missing_globals
-  | _ -> ()
-
-let remove_required (rel, pos) =
+let add_required compunit =
+  let add_required_by_reloc (rel, _pos) =
+    match rel with
+      Reloc_getglobal id ->
+        missing_globals := IdentSet.add id !missing_globals
+    | _ -> ()
+  in
+  let add_required_for_effects id =
+    missing_globals := IdentSet.add id !missing_globals
+  in
+  List.iter add_required_by_reloc compunit.cu_reloc;
+  List.iter add_required_for_effects compunit.cu_required_globals
+
+let remove_required (rel, _pos) =
   match rel with
     Reloc_setglobal id ->
       missing_globals := IdentSet.remove id !missing_globals
@@ -124,7 +132,8 @@ let scan_file obj_name tolink =
       seek_in ic compunit_pos;
       let compunit = (input_value ic : compilation_unit) in
       close_in ic;
-      List.iter add_required compunit.cu_reloc;
+      add_required compunit;
+      List.iter remove_required compunit.cu_reloc;
       Link_object(file_name, compunit) :: tolink
     end
     else if buffer = cma_magic_number then begin
@@ -142,8 +151,8 @@ let scan_file obj_name tolink =
             || !Clflags.link_everything
             || List.exists is_required compunit.cu_reloc
             then begin
+              add_required compunit;
               List.iter remove_required compunit.cu_reloc;
-              List.iter add_required compunit.cu_reloc;
               compunit :: reqd
             end else
               reqd)
@@ -318,7 +327,7 @@ let link_bytecode ppf tolink exec_name standalone =
     Bytesections.init_record outchan;
     (* The path to the bytecode interpreter (in use_runtime mode) *)
     if String.length !Clflags.use_runtime > 0 then begin
-      output_string outchan ("#!" ^ (make_absolute !Clflags.use_runtime));
+      output_string outchan (make_absolute !Clflags.use_runtime);
       output_char outchan '\n';
       Bytesections.record outchan "RNTM"
     end;
@@ -538,6 +547,14 @@ let link ppf objfiles output_name =
     else if !Clflags.output_c_object then "stdlib.cma" :: objfiles
     else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in
   let tolink = List.fold_right scan_file objfiles [] in
+  let missing_modules =
+    IdentSet.filter (fun id -> not (Ident.is_predef_exn id)) !missing_globals
+  in
+  begin
+    match IdentSet.elements missing_modules with
+    | [] -> ()
+    | id :: _ -> raise (Error (Required_module_unavailable (Ident.name id)))
+  end;
   Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; (* put user's libs last *)
   Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
                                                    (* put user's opts first *)
@@ -654,6 +671,8 @@ let report_error ppf = function
   | Not_compatible_32 ->
       fprintf ppf "Generated bytecode executable cannot be run\
                   \ on a 32-bit platform"
+  | Required_module_unavailable s ->
+      fprintf ppf "Required module `%s' is unavailable" s
 
 let () =
   Location.register_error_of_exn

diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli
index 113207fe6540ef4362483ab296e0b4e63cb63c97..42084fe7aa1d6c92abb9e5367a3e92017f09b2b3 100644 (file)
--- a/bytecomp/bytelink.mli
+++ b/bytecomp/bytelink.mli
@@ -33,6 +33,7 @@ type error =
   | File_exists of string
   | Cannot_open_dll of string
   | Not_compatible_32
+  | Required_module_unavailable of string
 
 exception Error of error
 

diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index 869cab79e1e20aa3ff0bc137e8461f45cb78a95b..2471ad59e4232a4603e6f397c9ec66f210262815 100644 (file)
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -186,7 +186,7 @@ let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs
 let build_global_target oc target_name members mapping pos coercion =
   let components =
     List.map2
-      (fun m (id1, id2) ->
+      (fun m (_id1, id2) ->
         match m.pm_kind with
         | PM_intf -> None
         | PM_impl _ -> Some id2)
@@ -207,6 +207,24 @@ let build_global_target oc target_name members mapping pos coercion =
 let package_object_files ppf files targetfile targetname coercion =
   let members =
     map_left_right read_member_info files in
+  let required_globals =
+    List.fold_right (fun compunit required_globals -> match compunit with
+        | { pm_kind = PM_intf } ->
+            required_globals
+        | { pm_kind = PM_impl { cu_required_globals; cu_reloc } } ->
+            let remove_required (rel, _pos) required_globals =
+              match rel with
+                Reloc_setglobal id ->
+                  Ident.Set.remove id required_globals
+              | _ ->
+                  required_globals
+            in
+            let required_globals =
+              List.fold_right remove_required cu_reloc required_globals
+            in
+            List.fold_right Ident.Set.add cu_required_globals required_globals)
+      members Ident.Set.empty
+  in
   let unit_names =
     List.map (fun m -> m.pm_name) members in
   let mapping =
@@ -232,7 +250,7 @@ let package_object_files ppf files targetfile targetname coercion =
     let pos_final = pos_out oc in
     let imports =
       List.filter
-        (fun (name, crc) -> not (List.mem name unit_names))
+        (fun (name, _crc) -> not (List.mem name unit_names))
         (Bytelink.extract_crc_interfaces()) in
     let compunit =
       { cu_name = targetname;
@@ -242,6 +260,7 @@ let package_object_files ppf files targetfile targetname coercion =
         cu_imports =
           (targetname, Some (Env.crc_of_unit targetname)) :: imports;
         cu_primitives = !primitives;
+        cu_required_globals = Ident.Set.elements required_globals;
         cu_force_link = !force_link;
         cu_debug = if pos_final > pos_debug then pos_debug else 0;
         cu_debugsize = pos_final - pos_debug } in

diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml
index 061e092328b16daeca2e17464779bb93e64a39b2..2beb0761b3ee422a7414d9375fd460116b435222 100644 (file)
--- a/bytecomp/bytesections.ml
+++ b/bytecomp/bytesections.ml
@@ -94,7 +94,7 @@ let read_section_struct ic name =
 
 let pos_first_section ic =
   in_channel_length ic - 16 - 8 * List.length !section_table -
-  List.fold_left (fun total (name, len) -> total + len) 0 !section_table
+  List.fold_left (fun total (_name, len) -> total + len) 0 !section_table
 
 let reset () =
   section_table := [];

diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli
index fe14af0b5294b45186b4d6d5d361e977831cea0b..7fbb35a04d70649004f915bdc99adfb1c6864389 100644 (file)
--- a/bytecomp/cmo_format.mli
+++ b/bytecomp/cmo_format.mli
@@ -32,6 +32,9 @@ type compilation_unit =
     cu_reloc: (reloc_info * int) list;  (* Relocation information *)
     cu_imports:
       (string * Digest.t option) list; (* Names and CRC of intfs imported *)
+    cu_required_globals: Ident.t list; (* Compilation units whose initialization
+                                          side effects must occur before this
+                                          one. *)
     cu_primitives: string list;         (* Primitives declared inside *)
     mutable cu_force_link: bool;        (* Must be linked even if unref'ed *)
     mutable cu_debug: int;              (* Position of debugging info, or 0 *)

diff --git a/bytecomp/debuginfo.ml b/bytecomp/debuginfo.ml
deleted file mode 100644 (file)
index 1ef4de2..0000000
--- a/bytecomp/debuginfo.ml
+++ /dev/null
@@ -1,81 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Lexing
-open Location
-
-type kind = Dinfo_call | Dinfo_raise
-
-type t = {
-  dinfo_kind: kind;
-  dinfo_file: string;
-  dinfo_line: int;
-  dinfo_char_start: int;
-  dinfo_char_end: int
-}
-
-let none = {
-  dinfo_kind = Dinfo_call;
-  dinfo_file = "";
-  dinfo_line = 0;
-  dinfo_char_start = 0;
-  dinfo_char_end = 0
-}
-
-(* PR#5643: cannot use (==) because Debuginfo values are marshalled *)
-let is_none t =
-  t = none
-
-let to_string d =
-  if d = none
-  then ""
-  else Printf.sprintf "{%s:%d,%d-%d}"
-           d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end
-
-let from_filename kind filename = {
-  dinfo_kind = kind;
-  dinfo_file = filename;
-  dinfo_line = 0;
-  dinfo_char_start = 0;
-  dinfo_char_end = 0
-}
-
-let from_location kind loc =
-  if loc == Location.none then none else
-  { dinfo_kind = kind;
-    dinfo_file = loc.loc_start.pos_fname;
-    dinfo_line = loc.loc_start.pos_lnum;
-    dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
-    dinfo_char_end =
-      if loc.loc_end.pos_fname = loc.loc_start.pos_fname
-      then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
-      else loc.loc_start.pos_cnum - loc.loc_start.pos_bol }
-
-let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc
-let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc
-
-let to_location d =
-  if is_none d then Location.none
-  else
-    let loc_start =
-      { Lexing.
-        pos_fname = d.dinfo_file;
-        pos_lnum = d.dinfo_line;
-        pos_bol = 0;
-        pos_cnum = d.dinfo_char_start;
-      }
-    in
-    let loc_end = { loc_start with pos_cnum = d.dinfo_char_end; } in
-    { Location. loc_ghost = false; loc_start; loc_end; }

diff --git a/bytecomp/debuginfo.mli b/bytecomp/debuginfo.mli
deleted file mode 100644 (file)
index b80fe99..0000000
--- a/bytecomp/debuginfo.mli
+++ /dev/null
@@ -1,38 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-type kind = Dinfo_call | Dinfo_raise
-
-type t = private {
-  dinfo_kind: kind;
-  dinfo_file: string;
-  dinfo_line: int;
-  dinfo_char_start: int;
-  dinfo_char_end: int
-}
-
-val none: t
-
-val is_none: t -> bool
-
-val to_string: t -> string
-
-val from_location: kind -> Location.t -> t
-val from_filename: kind -> string -> t
-
-val from_call: Lambda.lambda_event -> t
-val from_raise: Lambda.lambda_event -> t
-
-val to_location: t -> Location.t

diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 0b09b87b7569ad3c1babf7fd2cb549085e2db9b4..7857202ee505a7433009d2bba53db065846e5d7f 100644 (file)
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -365,7 +365,7 @@ let rec emit = function
 
 (* Emission to a file *)
 
-let to_file outchan unit_name objfile code =
+let to_file outchan unit_name objfile ~required_globals code =
   init();
   output_string outchan cmo_magic_number;
   let pos_depl = pos_out outchan in
@@ -392,6 +392,7 @@ let to_file outchan unit_name objfile code =
       cu_imports = Env.imports();
       cu_primitives = List.map Primitive.byte_name
                                !Translmod.primitive_declarations;
+      cu_required_globals = Ident.Set.elements required_globals;
       cu_force_link = false;
       cu_debug = pos_debug;
       cu_debugsize = size_debug } in

diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
index f4716e03f7622601bd28e9dab99bf1f80fcd5021..74a785ee0fbe160c85e759cf0a46382597ad41ea 100644 (file)
--- a/bytecomp/emitcode.mli
+++ b/bytecomp/emitcode.mli
@@ -18,11 +18,14 @@
 open Cmo_format
 open Instruct
 
-val to_file: out_channel -> string -> string -> instruction list -> unit
+val to_file: out_channel -> string -> string ->
+  required_globals:Ident.Set.t -> instruction list -> unit
         (* Arguments:
              channel on output file
              name of compilation unit implemented
              path of cmo file being written
+             required_globals: list of compilation units that must be
+               evaluated before this one
              list of instructions to emit *)
 val to_memory: instruction list -> instruction list ->
                     bytes * int * (reloc_info * int) list * debug_event list

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index b3011291c92803fd6e5e41225201d673ab9708df..b087ca5266523af1239e97c82d50ae5d2ceda246 100644 (file)
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -25,6 +25,7 @@ type compile_time_constant =
   | Ostype_unix
   | Ostype_win32
   | Ostype_cygwin
+  | Backend_type
 
 type loc_kind =
   | Loc_FILE
@@ -41,17 +42,23 @@ type initialization_or_assignment =
   | Initialization
   | Assignment
 
+type is_safe =
+  | Safe
+  | Unsafe
+
 type primitive =
-    Pidentity
+  | Pidentity
+  | Pbytes_to_string
+  | Pbytes_of_string
   | Pignore
-  | Prevapply of Location.t
-  | Pdirapply of Location.t
+  | Prevapply
+  | Pdirapply
   | Ploc of loc_kind
     (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
-  | Pmakeblock of int * mutable_flag
+  | Pmakeblock of int * mutable_flag * block_shape
   | Pfield of int
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int
@@ -66,7 +73,8 @@ type primitive =
   (* Boolean operations *)
   | Psequand | Psequor | Pnot
   (* Integer operations *)
-  | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
+  | Pnegint | Paddint | Psubint | Pmulint
+  | Pdivint of is_safe | Pmodint of is_safe
   | Pandint | Porint | Pxorint
   | Plslint | Plsrint | Pasrint
   | Pintcomp of comparison
@@ -78,7 +86,8 @@ type primitive =
   | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
   | Pfloatcomp of comparison
   (* String operations *)
-  | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
+  | Pstringlength | Pstringrefu  | Pstringrefs
+  | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
   (* Array operations *)
   | Pmakearray of array_kind * mutable_flag
   | Pduparray of array_kind * mutable_flag
@@ -101,8 +110,8 @@ type primitive =
   | Paddbint of boxed_integer
   | Psubbint of boxed_integer
   | Pmulbint of boxed_integer
-  | Pdivbint of boxed_integer
-  | Pmodbint of boxed_integer
+  | Pdivbint of { size : boxed_integer; is_safe : is_safe }
+  | Pmodbint of { size : boxed_integer; is_safe : is_safe }
   | Pandbint of boxed_integer
   | Porbint of boxed_integer
   | Pxorbint of boxed_integer
@@ -143,6 +152,12 @@ type primitive =
 and comparison =
     Ceq | Cneq | Clt | Cgt | Cle | Cge
 
+and value_kind =
+    Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
+
+and block_shape =
+  value_kind list option
+
 and array_kind =
     Pgenarray | Paddrarray | Pintarray | Pfloatarray
 
@@ -205,11 +220,12 @@ type lambda =
   | Lconst of structured_constant
   | Lapply of lambda_apply
   | Lfunction of lfunction
-  | Llet of let_kind * Ident.t * lambda * lambda
+  | Llet of let_kind * value_kind * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda
-  | Lprim of primitive * lambda list
+  | Lprim of primitive * lambda list * Location.t
   | Lswitch of lambda * lambda_switch
-  | Lstringswitch of lambda * (string * lambda) list * lambda option
+  | Lstringswitch of
+      lambda * (string * lambda) list * lambda option * Location.t
   | Lstaticraise of int * lambda list
   | Lstaticcatch of lambda * (int * Ident.t list) * lambda
   | Ltrywith of lambda * Ident.t * lambda
@@ -226,7 +242,8 @@ and lfunction =
   { kind: function_kind;
     params: Ident.t list;
     body: lambda;
-    attr: function_attribute; } (* specified with [@inline] attribute *)
+    attr: function_attribute; (* specified with [@inline] attribute *)
+    loc: Location.t; }
 
 and lambda_apply =
   { ap_func : lambda;
@@ -256,8 +273,10 @@ and lambda_event_kind =
   | Lev_pseudo
 
 type program =
-  { code : lambda;
-    main_module_block_size : int; }
+  { module_ident : Ident.t;
+    main_module_block_size : int;
+    required_globals : Ident.Set.t;
+    code : lambda }
 
 let const_unit = Const_pointer 0
 
@@ -300,23 +319,26 @@ let make_key e =
         Lapply {ap with ap_func = tr_rec env ap.ap_func;
                         ap_args = tr_recs env ap.ap_args;
                         ap_loc = Location.none}
-    | Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *)
+    | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *)
         let ex = tr_rec env ex in
         tr_rec (Ident.add x ex env) e
-    | Llet (str,x,ex,e) ->
+    | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x ->
+        tr_rec env ex
+    | Llet (str,k,x,ex,e) ->
      (* Because of side effects, keep other lets with normalized names *)
         let ex = tr_rec env ex in
         let y = make_key x in
-        Llet (str,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
-    | Lprim (p,es) ->
-        Lprim (p,tr_recs env es)
+        Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
+    | Lprim (p,es,_) ->
+        Lprim (p,tr_recs env es, Location.none)
     | Lswitch (e,sw) ->
         Lswitch (tr_rec env e,tr_sw env sw)
-    | Lstringswitch (e,sw,d) ->
+    | Lstringswitch (e,sw,d,_) ->
         Lstringswitch
           (tr_rec env e,
            List.map (fun (s,e) -> s,tr_rec env e) sw,
-           tr_opt env d)
+           tr_opt env d,
+          Location.none)
     | Lstaticraise (i,es) ->
         Lstaticraise (i,tr_recs env es)
     | Lstaticcatch (e1,xs,e2) ->
@@ -329,7 +351,7 @@ let make_key e =
         Lsequence (tr_rec env e1,tr_rec env e2)
     | Lassign (x,e) ->
         Lassign (x,tr_rec env e)
-    | Lsend (m,e1,e2,es,loc) ->
+    | Lsend (m,e1,e2,es,_loc) ->
         Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none)
     | Lifused (id,e) -> Lifused (id,tr_rec env e)
     | Lletrec _|Lfunction _
@@ -360,16 +382,16 @@ let make_key e =
 let name_lambda strict arg fn =
   match arg with
     Lvar id -> fn id
-  | _ -> let id = Ident.create "let" in Llet(strict, id, arg, fn id)
+  | _ -> let id = Ident.create "let" in Llet(strict, Pgenval, id, arg, fn id)
 
 let name_lambda_list args fn =
   let rec name_list names = function
     [] -> fn (List.rev names)
-  | (Lvar id as arg) :: rem ->
+  | (Lvar _ as arg) :: rem ->
       name_list (arg :: names) rem
   | arg :: rem ->
       let id = Ident.create "let" in
-      Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in
+      Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in
   name_list [] args
 
 
@@ -382,29 +404,29 @@ let iter f = function
   | Lconst _ -> ()
   | Lapply{ap_func = fn; ap_args = args} ->
       f fn; List.iter f args
-  | Lfunction{kind; params; body} ->
+  | Lfunction{body} ->
       f body
-  | Llet(str, id, arg, body) ->
+  | Llet(_str, _k, _id, arg, body) ->
       f arg; f body
   | Lletrec(decl, body) ->
       f body;
-      List.iter (fun (id, exp) -> f exp) decl
-  | Lprim(p, args) ->
+      List.iter (fun (_id, exp) -> f exp) decl
+  | Lprim(_p, args, _loc) ->
       List.iter f args
   | Lswitch(arg, sw) ->
       f arg;
-      List.iter (fun (key, case) -> f case) sw.sw_consts;
-      List.iter (fun (key, case) -> f case) sw.sw_blocks;
+      List.iter (fun (_key, case) -> f case) sw.sw_consts;
+      List.iter (fun (_key, case) -> f case) sw.sw_blocks;
       iter_opt f sw.sw_failaction
-  | Lstringswitch (arg,cases,default) ->
+  | Lstringswitch (arg,cases,default,_) ->
       f arg ;
       List.iter (fun (_,act) -> f act) cases ;
       iter_opt f default
   | Lstaticraise (_,args) ->
       List.iter f args
-  | Lstaticcatch(e1, (_,vars), e2) ->
+  | Lstaticcatch(e1, _, e2) ->
       f e1; f e2
-  | Ltrywith(e1, exn, e2) ->
+  | Ltrywith(e1, _, e2) ->
       f e1; f e2
   | Lifthenelse(e1, e2, e3) ->
       f e1; f e2; f e3
@@ -412,23 +434,19 @@ let iter f = function
       f e1; f e2
   | Lwhile(e1, e2) ->
       f e1; f e2
-  | Lfor(v, e1, e2, dir, e3) ->
+  | Lfor(_v, e1, e2, _dir, e3) ->
       f e1; f e2; f e3
-  | Lassign(id, e) ->
+  | Lassign(_, e) ->
       f e
-  | Lsend (k, met, obj, args, _) ->
+  | Lsend (_k, met, obj, args, _) ->
       List.iter f (met::obj::args)
-  | Levent (lam, evt) ->
+  | Levent (lam, _evt) ->
       f lam
-  | Lifused (v, e) ->
+  | Lifused (_v, e) ->
       f e
 
 
-module IdentSet =
-  Set.Make(struct
-    type t = Ident.t
-    let compare = compare
-  end)
+module IdentSet = Set.Make(Ident)
 
 let free_ids get l =
   let fv = ref IdentSet.empty in
@@ -436,19 +454,19 @@ let free_ids get l =
     iter free l;
     fv := List.fold_right IdentSet.add (get l) !fv;
     match l with
-      Lfunction{kind; params; body} ->
+      Lfunction{params} ->
         List.iter (fun param -> fv := IdentSet.remove param !fv) params
-    | Llet(str, id, arg, body) ->
+    | Llet(_str, _k, id, _arg, _body) ->
         fv := IdentSet.remove id !fv
-    | Lletrec(decl, body) ->
-        List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
-    | Lstaticcatch(e1, (_,vars), e2) ->
+    | Lletrec(decl, _body) ->
+        List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl
+    | Lstaticcatch(_e1, (_,vars), _e2) ->
         List.iter (fun id -> fv := IdentSet.remove id !fv) vars
-    | Ltrywith(e1, exn, e2) ->
+    | Ltrywith(_e1, exn, _e2) ->
         fv := IdentSet.remove exn !fv
-    | Lfor(v, e1, e2, dir, e3) ->
+    | Lfor(v, _e1, _e2, _dir, _e3) ->
         fv := IdentSet.remove v !fv
-    | Lassign(id, e) ->
+    | Lassign(id, _e) ->
         fv := IdentSet.add id !fv
     | Lvar _ | Lconst _ | Lapply _
     | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
@@ -460,7 +478,7 @@ let free_variables l =
   free_ids (function Lvar id -> [id] | _ -> []) l
 
 let free_methods l =
-  free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l
+  free_ids (function Lsend(Self, Lvar meth, _, _, _) -> [meth] | _ -> []) l
 
 (* Check if an action has a "when" guard *)
 let raise_count = ref 0
@@ -479,16 +497,16 @@ let next_negative_raise_count () =
 let staticfail = Lstaticraise (0,[])
 
 let rec is_guarded = function
-  | Lifthenelse( cond, body, Lstaticraise (0,[])) -> true
-  | Llet(str, id, lam, body) -> is_guarded body
-  | Levent(lam, ev) -> is_guarded lam
+  | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true
+  | Llet(_str, _k, _id, _lam, body) -> is_guarded body
+  | Levent(lam, _ev) -> is_guarded lam
   | _ -> false
 
 let rec patch_guarded patch = function
   | Lifthenelse (cond, body, Lstaticraise (0,[])) ->
       Lifthenelse (cond, body, patch)
-  | Llet(str, id, lam, body) ->
-      Llet (str, id, lam, patch_guarded patch body)
+  | Llet(str, k, id, lam, body) ->
+      Llet (str, k, id, lam, patch_guarded patch body)
   | Levent(lam, ev) ->
       Levent (patch_guarded patch lam, ev)
   | _ -> fatal_error "Lambda.patch_guarded"
@@ -497,10 +515,12 @@ let rec patch_guarded patch = function
 
 let rec transl_normal_path = function
     Pident id ->
-      if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
-  | Pdot(p, s, pos) ->
-      Lprim(Pfield pos, [transl_normal_path p])
-  | Papply(p1, p2) ->
+      if Ident.global id
+      then Lprim(Pgetglobal id, [], Location.none)
+      else Lvar id
+  | Pdot(p, _s, pos) ->
+      Lprim(Pfield pos, [transl_normal_path p], Location.none)
+  | Papply _ ->
       fatal_error "Lambda.transl_path"
 
 (* Translation of value identifiers *)
@@ -526,23 +546,23 @@ let subst_lambda s lam =
   let rec subst = function
     Lvar id as l ->
       begin try Ident.find_same id s with Not_found -> l end
-  | Lconst sc as l -> l
+  | Lconst _ as l -> l
   | Lapply ap ->
       Lapply{ap with ap_func = subst ap.ap_func;
                      ap_args = List.map subst ap.ap_args}
-  | Lfunction{kind; params; body; attr} ->
-      Lfunction{kind; params; body = subst body; attr}
-  | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
+  | Lfunction{kind; params; body; attr; loc} ->
+      Lfunction{kind; params; body = subst body; attr; loc}
+  | Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body)
   | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
-  | Lprim(p, args) -> Lprim(p, List.map subst args)
+  | Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc)
   | Lswitch(arg, sw) ->
       Lswitch(subst arg,
               {sw with sw_consts = List.map subst_case sw.sw_consts;
                        sw_blocks = List.map subst_case sw.sw_blocks;
                        sw_failaction = subst_opt  sw.sw_failaction; })
-  | Lstringswitch (arg,cases,default) ->
+  | Lstringswitch (arg,cases,default,loc) ->
       Lstringswitch
-        (subst arg,List.map subst_strcase cases,subst_opt default)
+        (subst arg,List.map subst_strcase cases,subst_opt default,loc)
   | Lstaticraise (i,args) ->  Lstaticraise (i, List.map subst args)
   | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
   | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
@@ -566,8 +586,8 @@ let subst_lambda s lam =
 let rec map f lam =
   let lam =
     match lam with
-    | Lvar v -> lam
-    | Lconst cst -> lam
+    | Lvar _ -> lam
+    | Lconst _ -> lam
     | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall;
           ap_inlined; ap_specialised } ->
         Lapply {
@@ -578,14 +598,14 @@ let rec map f lam =
           ap_inlined;
           ap_specialised;
         }
-    | Lfunction { kind; params; body; attr; } ->
-        Lfunction { kind; params; body = map f body; attr; }
-    | Llet (str, v, e1, e2) ->
-        Llet (str, v, map f e1, map f e2)
+    | Lfunction { kind; params; body; attr; loc; } ->
+        Lfunction { kind; params; body = map f body; attr; loc; }
+    | Llet (str, k, v, e1, e2) ->
+        Llet (str, k, v, map f e1, map f e2)
     | Lletrec (idel, e2) ->
         Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2)
-    | Lprim (p, el) ->
-        Lprim (p, List.map (map f) el)
+    | Lprim (p, el, loc) ->
+        Lprim (p, List.map (map f) el, loc)
     | Lswitch (e, sw) ->
         Lswitch (map f e,
           { sw_numconsts = sw.sw_numconsts;
@@ -594,11 +614,12 @@ let rec map f lam =
             sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks;
             sw_failaction = Misc.may_map (map f) sw.sw_failaction;
           })
-    | Lstringswitch (e, sw, default) ->
+    | Lstringswitch (e, sw, default, loc) ->
         Lstringswitch (
           map f e,
           List.map (fun (s, e) -> (s, map f e)) sw,
-          Misc.may_map (map f) default)
+          Misc.may_map (map f) default,
+          loc)
     | Lstaticraise (i, args) ->
         Lstaticraise (i, List.map (map f) args)
     | Lstaticcatch (body, id, handler) ->
@@ -629,7 +650,7 @@ let rec map f lam =
 let bind str var exp body =
   match exp with
     Lvar var' when Ident.same var var' -> body
-  | _ -> Llet(str, var, exp, body)
+  | _ -> Llet(str, Pgenval, var, exp, body)
 
 and commute_comparison = function
 | Ceq -> Ceq| Cneq -> Cneq

diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index def712afeac68c15f7ff4b2d8b94353b86a67c6b..f346b0e72ffb5f7d13cce7c06cd6a6990b793f31 100644 (file)
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -25,6 +25,7 @@ type compile_time_constant =
   | Ostype_unix
   | Ostype_win32
   | Ostype_cygwin
+  | Backend_type
 
 type loc_kind =
   | Loc_FILE
@@ -44,17 +45,23 @@ type initialization_or_assignment =
   | Initialization
   | Assignment
 
+type is_safe =
+  | Safe
+  | Unsafe
+
 type primitive =
-    Pidentity
+  | Pidentity
+  | Pbytes_to_string
+  | Pbytes_of_string
   | Pignore
-  | Prevapply of Location.t
-  | Pdirapply of Location.t
+  | Prevapply
+  | Pdirapply
   | Ploc of loc_kind
     (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
-  | Pmakeblock of int * mutable_flag
+  | Pmakeblock of int * mutable_flag * block_shape
   | Pfield of int
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Pfloatfield of int
@@ -69,7 +76,8 @@ type primitive =
   (* Boolean operations *)
   | Psequand | Psequor | Pnot
   (* Integer operations *)
-  | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
+  | Pnegint | Paddint | Psubint | Pmulint
+  | Pdivint of is_safe | Pmodint of is_safe
   | Pandint | Porint | Pxorint
   | Plslint | Plsrint | Pasrint
   | Pintcomp of comparison
@@ -81,7 +89,8 @@ type primitive =
   | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
   | Pfloatcomp of comparison
   (* String operations *)
-  | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
+  | Pstringlength | Pstringrefu  | Pstringrefs
+  | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
   (* Array operations *)
   | Pmakearray of array_kind * mutable_flag
   | Pduparray of array_kind * mutable_flag
@@ -107,8 +116,8 @@ type primitive =
   | Paddbint of boxed_integer
   | Psubbint of boxed_integer
   | Pmulbint of boxed_integer
-  | Pdivbint of boxed_integer
-  | Pmodbint of boxed_integer
+  | Pdivbint of { size : boxed_integer; is_safe : is_safe }
+  | Pmodbint of { size : boxed_integer; is_safe : is_safe }
   | Pandbint of boxed_integer
   | Porbint of boxed_integer
   | Pxorbint of boxed_integer
@@ -152,6 +161,12 @@ and comparison =
 and array_kind =
     Pgenarray | Paddrarray | Pintarray | Pfloatarray
 
+and value_kind =
+    Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
+
+and block_shape =
+  value_kind list option
+
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
@@ -203,7 +218,8 @@ type let_kind = Strict | Alias | StrictOpt | Variable
       in e'
     StrictOpt: e does not have side-effects, but depend on the store;
       we can discard e if x does not appear in e'
-    Variable: the variable x is assigned later in e' *)
+    Variable: the variable x is assigned later in e'
+ *)
 
 type meth_kind = Self | Public | Cached
 
@@ -220,13 +236,14 @@ type lambda =
   | Lconst of structured_constant
   | Lapply of lambda_apply
   | Lfunction of lfunction
-  | Llet of let_kind * Ident.t * lambda * lambda
+  | Llet of let_kind * value_kind * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda
-  | Lprim of primitive * lambda list
+  | Lprim of primitive * lambda list * Location.t
   | Lswitch of lambda * lambda_switch
 (* switch on strings, clauses are sorted by string order,
    strings are pairwise distinct *)
-  | Lstringswitch of lambda * (string * lambda) list * lambda option
+  | Lstringswitch of
+      lambda * (string * lambda) list * lambda option * Location.t
   | Lstaticraise of int * lambda list
   | Lstaticcatch of lambda * (int * Ident.t list) * lambda
   | Ltrywith of lambda * Ident.t * lambda
@@ -243,7 +260,8 @@ and lfunction =
   { kind: function_kind;
     params: Ident.t list;
     body: lambda;
-    attr: function_attribute; } (* specified with [@inline] attribute *)
+    attr: function_attribute; (* specified with [@inline] attribute *)
+    loc : Location.t; }
 
 and lambda_apply =
   { ap_func : lambda;
@@ -272,10 +290,22 @@ and lambda_event_kind =
   | Lev_pseudo
 
 type program =
-  { code : lambda;
-    main_module_block_size : int; }
-(* Lambda code for the Closure middle-end. The main module block size
-   is required for preallocating the block *)
+  { module_ident : Ident.t;
+    main_module_block_size : int;
+    required_globals : Ident.Set.t;    (* Modules whose initializer side effects
+                                          must occur before [code]. *)
+    code : lambda }
+(* Lambda code for the middle-end.
+   * In the closure case the code is a sequence of assignments to a
+     preallocated block of size [main_module_block_size] using
+     (Setfield(Getglobal(module_ident))). The size is used to preallocate
+     the block.
+   * In the flambda case the code is an expression returning a block
+     value of size [main_module_block_size]. The size is used to build
+     the module root as an initialize_symbol
+     Initialize_symbol(module_name, 0,
+       [getfield 0; ...; getfield (main_module_block_size - 1)])
+*)
 
 (* Sharing key *)
 val make_key: lambda -> lambda option

diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 7d541606834e97a49637c1572e70696614f21a53..b2dcd248beb86bf3fb84388432976df87bfb48c7 100644 (file)
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -72,7 +72,7 @@ let lshift {left=left ; right=right} = match right with
 | _ ->  assert false
 
 let lforget {left=left ; right=right} = match right with
-| x::xs -> {left=omega::left ; right=xs}
+| _::xs -> {left=omega::left ; right=xs}
 |  _ -> assert false
 
 let rec small_enough n = function
@@ -174,7 +174,7 @@ let ctx_matcher p =
       | Cstr_extension _ ->
           let nargs = List.length omegas in
           (fun q rem -> match q.pat_desc with
-          | Tpat_construct (_, cstr',args)
+          | Tpat_construct (_, _cstr',args)
             when List.length args = nargs ->
                 p,args @ rem
           | Tpat_any -> p,omegas @ rem
@@ -396,7 +396,7 @@ type pm_half_compiled_info =
 
 let pretty_cases cases =
   List.iter
-    (fun ((ps),l) ->
+    (fun (ps,_l) ->
       List.iter
         (fun p ->
           Parmatch.top_pretty Format.str_formatter p ;
@@ -483,7 +483,7 @@ let make_catch d k = match d with
 (* Introduce a catch, if worth it, delayed version *)
 let rec as_simple_exit = function
   | Lstaticraise (i,[]) -> Some i
-  | Llet (Alias,_,_,e) -> as_simple_exit e
+  | Llet (Alias,_k,_,_,e) -> as_simple_exit e
   | _ -> None
 
 
@@ -1078,7 +1078,7 @@ and precompile_var  args cls def k = match args with
 | []  -> assert false
 | _::((Lvar v as av,_) as arg)::rargs ->
     begin match cls with
-    | [ps,_] -> (* as splitted as it can *)
+    | [_] -> (* as splitted as it can *)
         dont_precompile_var args cls def k
     | _ ->
 (* Precompile *)
@@ -1113,7 +1113,7 @@ and dont_precompile_var args cls def k =
 
 and is_exc p = match p.pat_desc with
 | Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2
-| Tpat_alias (p,v,_) -> is_exc p
+| Tpat_alias (p,_,_) -> is_exc p
 | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true
 | _ -> false
 
@@ -1286,11 +1286,11 @@ let divide_constant ctx m =
 (* Matching against a constructor *)
 
 
-let make_field_args binding_kind arg first_pos last_pos argl =
+let make_field_args loc binding_kind arg first_pos last_pos argl =
   let rec make_args pos =
     if pos > last_pos
     then argl
-    else (Lprim(Pfield pos, [arg]), binding_kind) :: make_args (pos + 1)
+    else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1)
   in make_args first_pos
 
 let get_key_constr = function
@@ -1325,7 +1325,7 @@ let matcher_constr cstr = match cstr.cstr_arity with
         | None, None -> raise NoMatch
         | Some r1, None -> r1
         | None, Some r2 -> r2
-        | Some (a1::rem1), Some (a2::_) ->
+        | Some (a1::_), Some (a2::_) ->
             {a1 with
              pat_loc = Location.none ;
              pat_desc = Tpat_or (a1, a2, None)}::
@@ -1347,16 +1347,17 @@ let matcher_constr cstr = match cstr.cstr_arity with
 
 let make_constr_matching p def ctx = function
     [] -> fatal_error "Matching.make_constr_matching"
-  | ((arg, mut) :: argl) ->
+  | ((arg, _mut) :: argl) ->
       let cstr = pat_as_constr p in
       let newargs =
         if cstr.cstr_inlined <> None then
           (arg, Alias) :: argl
         else match cstr.cstr_tag with
           Cstr_constant _ | Cstr_block _ ->
-            make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl
+            make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl
+        | Cstr_unboxed -> (arg, Alias) :: argl
         | Cstr_extension _ ->
-            make_field_args Alias arg 1 cstr.cstr_arity argl in
+            make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in
       {pm=
         {cases = []; args = newargs;
           default = make_default (matcher_constr cstr) def} ;
@@ -1387,7 +1388,7 @@ let rec matcher_variant_const lab p rem = match p.pat_desc with
 
 let make_variant_matching_constant p lab def ctx = function
     [] -> fatal_error "Matching.make_variant_matching_constant"
-  | ((arg, mut) :: argl) ->
+  | (_ :: argl) ->
       let def = make_default (matcher_variant_const lab) def
       and ctx = filter_ctx p ctx in
       {pm={ cases = []; args = argl ; default=def} ;
@@ -1403,11 +1404,11 @@ let matcher_variant_nonconst lab p rem = match p.pat_desc with
 
 let make_variant_matching_nonconst p lab def ctx = function
     [] -> fatal_error "Matching.make_variant_matching_nonconst"
-  | ((arg, mut) :: argl) ->
+  | ((arg, _mut) :: argl) ->
       let def = make_default (matcher_variant_nonconst lab) def
       and ctx = filter_ctx p ctx in
       {pm=
-        {cases = []; args = (Lprim(Pfield 1, [arg]), Alias) :: argl;
+        {cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl;
           default=def} ;
         ctx=ctx ;
         pat = normalize_pat p}
@@ -1431,7 +1432,7 @@ let divide_variant row ctx {cases = cl; args = al; default=def} =
               add (make_variant_matching_nonconst p lab def ctx) variants
                 (=) (Cstr_block tag) (pat :: patl, action) al
         end
-    | cl -> []
+    | _ -> []
   in
   divide cl
 
@@ -1486,7 +1487,9 @@ let get_mod_field modname field =
       with Not_found ->
         fatal_error ("Primitive "^modname^"."^field^" not found.")
       in
-      Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])])
+      Lprim(Pfield p,
+            [Lprim(Pgetglobal mod_ident, [], Location.none)],
+            Location.none)
     with Not_found -> fatal_error ("Module "^modname^" unavailable.")
   )
 
@@ -1509,17 +1512,19 @@ let inline_lazy_force_cond arg loc =
   let varg = Lvar idarg in
   let tag = Ident.create "tag" in
   let force_fun = Lazy.force code_force_lazy_block in
-  Llet(Strict, idarg, arg,
-       Llet(Alias, tag, Lprim(Pccall prim_obj_tag, [varg]),
+  Llet(Strict, Pgenval, idarg, arg,
+       Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc),
             Lifthenelse(
               (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
               Lprim(Pintcomp Ceq,
-                    [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]),
-              Lprim(Pfield 0, [varg]),
+                    [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))],
+                    loc),
+              Lprim(Pfield 0, [varg], loc),
               Lifthenelse(
                 (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
                 Lprim(Pintcomp Ceq,
-                      [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]),
+                      [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))],
+                      loc),
                 Lapply{ap_should_be_tailcall=false;
                        ap_loc=loc;
                        ap_func=force_fun;
@@ -1533,15 +1538,15 @@ let inline_lazy_force_switch arg loc =
   let idarg = Ident.create "lzarg" in
   let varg = Lvar idarg in
   let force_fun = Lazy.force code_force_lazy_block in
-  Llet(Strict, idarg, arg,
+  Llet(Strict, Pgenval, idarg, arg,
        Lifthenelse(
-         Lprim(Pisint, [varg]), varg,
+         Lprim(Pisint, [varg], loc), varg,
          (Lswitch
             (varg,
              { sw_numconsts = 0; sw_consts = [];
                sw_numblocks = 256;  (* PR#6033 - tag ranges from 0 to 255 *)
                sw_blocks =
-                 [ (Obj.forward_tag, Lprim(Pfield 0, [varg]));
+                 [ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc));
                    (Obj.lazy_tag,
                     Lapply{ap_should_be_tailcall=false;
                            ap_loc=loc;
@@ -1562,7 +1567,7 @@ let inline_lazy_force arg loc =
 
 let make_lazy_matching def = function
     [] -> fatal_error "Matching.make_lazy_matching"
-  | (arg,mut) :: argl ->
+  | (arg,_mut) :: argl ->
       { cases = [];
         args =
           (inline_lazy_force arg Location.none, Strict) :: argl;
@@ -1589,13 +1594,13 @@ let matcher_tuple arity p rem = match p.pat_desc with
 | Tpat_var _          -> get_args_tuple arity omega rem
 | _                   ->  get_args_tuple arity p rem
 
-let make_tuple_matching arity def = function
+let make_tuple_matching loc arity def = function
     [] -> fatal_error "Matching.make_tuple_matching"
-  | (arg, mut) :: argl ->
+  | (arg, _mut) :: argl ->
       let rec make_args pos =
         if pos >= arity
         then argl
-        else (Lprim(Pfield pos, [arg]), Alias) :: make_args (pos + 1) in
+        else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in
       {cases = []; args = make_args 0 ;
         default=make_default (matcher_tuple arity) def}
 
@@ -1603,7 +1608,7 @@ let make_tuple_matching arity def = function
 let divide_tuple arity p ctx pm =
   divide_line
     (filter_ctx p)
-    (make_tuple_matching arity)
+    (make_tuple_matching p.pat_loc arity)
     (get_args_tuple  arity) p ctx pm
 
 (* Matching against a record pattern *)
@@ -1626,23 +1631,25 @@ let matcher_record num_fields p rem = match p.pat_desc with
 | Tpat_var _      -> get_args_record num_fields omega rem
 | _               -> get_args_record num_fields p rem
 
-let make_record_matching all_labels def = function
+let make_record_matching loc all_labels def = function
     [] -> fatal_error "Matching.make_record_matching"
-  | ((arg, mut) :: argl) ->
+  | ((arg, _mut) :: argl) ->
       let rec make_args pos =
         if pos >= Array.length all_labels then argl else begin
           let lbl = all_labels.(pos) in
           let access =
             match lbl.lbl_repres with
-              Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos
-            | Record_float -> Pfloatfield lbl.lbl_pos
-            | Record_extension -> Pfield (lbl.lbl_pos + 1)
+            | Record_regular | Record_inlined _ ->
+              Lprim (Pfield lbl.lbl_pos, [arg], loc)
+            | Record_unboxed _ -> arg
+            | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc)
+            | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc)
           in
           let str =
             match lbl.lbl_mut with
               Immutable -> Alias
             | Mutable -> StrictOpt in
-          (Lprim(access, [arg]), str) :: make_args(pos + 1)
+          (access, str) :: make_args(pos + 1)
         end in
       let nfields = Array.length all_labels in
       let def= make_default (matcher_record nfields) def in
@@ -1653,7 +1660,7 @@ let divide_record all_labels p ctx pm =
   let get_args = get_args_record (Array.length all_labels) in
   divide_line
     (filter_ctx p)
-    (make_record_matching all_labels)
+    (make_record_matching p.pat_loc all_labels)
     get_args
     p ctx pm
 
@@ -1675,12 +1682,14 @@ let matcher_array len p rem = match p.pat_desc with
 
 let make_array_matching kind p def ctx = function
   | [] -> fatal_error "Matching.make_array_matching"
-  | ((arg, mut) :: argl) ->
+  | ((arg, _mut) :: argl) ->
       let len = get_key_array p in
       let rec make_args pos =
         if pos >= len
         then argl
-        else (Lprim(Parrayrefu kind, [arg; Lconst(Const_base(Const_int pos))]),
+        else (Lprim(Parrayrefu kind,
+                    [arg; Lconst(Const_base(Const_int pos))],
+                    p.pat_loc),
               StrictOpt) :: make_args (pos + 1) in
       let def = make_default (matcher_array len) def
       and ctx = filter_ctx p ctx in
@@ -1726,12 +1735,12 @@ let bind_sw arg k = match arg with
 | Lvar _ -> k arg
 | _ ->
     let id = Ident.create "switch" in
-    Llet (Strict,id,arg,k (Lvar id))
+    Llet (Strict,Pgenval,id,arg,k (Lvar id))
 
 
 (* Sequential equality tests *)
 
-let make_string_test_sequence arg sw d =
+let make_string_test_sequence loc arg sw d =
   let d,sw = match d with
   | None ->
       begin match sw with
@@ -1746,7 +1755,7 @@ let make_string_test_sequence arg sw d =
           Lifthenelse
             (Lprim
                (prim_string_notequal,
-                [arg; Lconst (Const_immstring s)]),
+                [arg; Lconst (Const_immstring s)], loc),
              k,lam))
         sw d)
 
@@ -1760,40 +1769,40 @@ let rec split k xs = match xs with
 
 let zero_lam  = Lconst (Const_base (Const_int 0))
 
-let tree_way_test arg lt eq gt =
+let tree_way_test loc arg lt eq gt =
   Lifthenelse
-    (Lprim (Pintcomp Clt,[arg;zero_lam]),lt,
-     Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg]),gt,eq))
+    (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt,
+     Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq))
 
 (* Dichotomic tree *)
 
 
-let rec do_make_string_test_tree arg sw delta d =
+let rec do_make_string_test_tree loc arg sw delta d =
   let len = List.length sw in
   if len <= strings_test_threshold+delta then
-    make_string_test_sequence arg sw d
+    make_string_test_sequence loc arg sw d
   else
     let lt,(s,act),gt = split len sw in
     bind_sw
       (Lprim
          (prim_string_compare,
-          [arg; Lconst (Const_immstring s)];))
+          [arg; Lconst (Const_immstring s)], loc;))
       (fun r ->
-        tree_way_test r
-          (do_make_string_test_tree arg lt delta d)
+        tree_way_test loc r
+          (do_make_string_test_tree loc arg lt delta d)
           act
-          (do_make_string_test_tree arg gt delta d))
+          (do_make_string_test_tree loc arg gt delta d))
 
 (* Entry point *)
-let expand_stringswitch arg sw d = match d with
+let expand_stringswitch loc arg sw d = match d with
 | None ->
     bind_sw arg
-      (fun arg -> do_make_string_test_tree arg sw 0 None)
+      (fun arg -> do_make_string_test_tree loc arg sw 0 None)
 | Some e ->
     bind_sw arg
       (fun arg ->
         make_catch e
-          (fun d -> do_make_string_test_tree arg sw 1 (Some d)))
+          (fun d -> do_make_string_test_tree loc arg sw 1 (Some d)))
 
 (**********************)
 (* Generic test trees *)
@@ -1857,24 +1866,24 @@ let rec cut n l =
     [] -> raise (Invalid_argument "cut")
   | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2
 
-let rec do_tests_fail fail tst arg = function
+let rec do_tests_fail loc fail tst arg = function
   | [] -> fail
   | (c, act)::rem ->
       Lifthenelse
-        (Lprim (tst, [arg ; Lconst (Const_base c)]),
-         do_tests_fail fail tst arg rem,
+        (Lprim (tst, [arg ; Lconst (Const_base c)], loc),
+         do_tests_fail loc fail tst arg rem,
          act)
 
-let rec do_tests_nofail tst arg = function
+let rec do_tests_nofail loc tst arg = function
   | [] -> fatal_error "Matching.do_tests_nofail"
   | [_,act] -> act
   | (c,act)::rem ->
       Lifthenelse
-        (Lprim (tst, [arg ; Lconst (Const_base c)]),
-         do_tests_nofail tst arg rem,
+        (Lprim (tst, [arg ; Lconst (Const_base c)], loc),
+         do_tests_nofail loc tst arg rem,
          act)
 
-let make_test_sequence fail tst lt_tst arg const_lambda_list =
+let make_test_sequence loc fail tst lt_tst arg const_lambda_list =
   let const_lambda_list = sort_lambda_list const_lambda_list in
   let hs,const_lambda_list,fail =
     share_actions_tree const_lambda_list fail in
@@ -1883,13 +1892,15 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list =
     if List.length const_lambda_list >= 4 && lt_tst <> Pignore then
       split_sequence const_lambda_list
     else match fail with
-    | None -> do_tests_nofail tst arg const_lambda_list
-    | Some fail -> do_tests_fail fail tst arg const_lambda_list
+    | None -> do_tests_nofail loc tst arg const_lambda_list
+    | Some fail -> do_tests_fail loc fail tst arg const_lambda_list
 
   and split_sequence const_lambda_list =
     let list1, list2 =
       cut (List.length const_lambda_list / 2) const_lambda_list in
-    Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]),
+    Lifthenelse(Lprim(lt_tst,
+                      [arg; Lconst(Const_base (fst(List.hd list2)))],
+                      loc),
                 make_test_sequence list1, make_test_sequence list2)
   in
   hs (make_test_sequence const_lambda_list)
@@ -1907,10 +1918,10 @@ module SArg = struct
 
   type act = Lambda.lambda
 
-  let make_prim p args = Lprim (p,args)
+  let make_prim p args = Lprim (p,args,Location.none)
   let make_offset arg n = match n with
   | 0 -> arg
-  | _ -> Lprim (Poffsetint n,[arg])
+  | _ -> Lprim (Poffsetint n,[arg],Location.none)
 
   let bind arg body =
     let newvar,newarg = match arg with
@@ -1920,8 +1931,8 @@ module SArg = struct
         newvar,Lvar newvar in
     bind Alias newvar arg (body newarg)
   let make_const i = Lconst (Const_base (Const_int i))
-  let make_isout h arg = Lprim (Pisout, [h ; arg])
-  let make_isin h arg = Lprim (Pnot,[make_isout h arg])
+  let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none)
+  let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none)
   let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
   let make_switch arg cases acts =
     let l = ref [] in
@@ -2018,7 +2029,7 @@ let get_edges low high l = match l with
 let as_interval_canfail fail low high l =
   let store = StoreExp.mk_store () in
 
-  let do_store tag act =
+  let do_store _tag act =
 
     let i =  store.act_store act in
 (*
@@ -2188,7 +2199,7 @@ let mk_failaction_pos partial seen ctx defs  =
   | _,(pss,idef)::rem ->
       let now, later =
         List.partition
-          (fun (p,p_ctx) -> ctx_match p_ctx pss) to_test in
+          (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in
       match now with
       | [] -> scan_def env to_test rem
       | _  -> scan_def ((List.map fst now,idef)::env) later rem in
@@ -2218,8 +2229,8 @@ let mk_failaction_pos partial seen ctx defs  =
     fail,[],jumps
   end
 
-let combine_constant arg cst partial ctx def
-    (const_lambda_list, total, pats) =
+let combine_constant loc arg cst partial ctx def
+    (const_lambda_list, total, _pats) =
   let fail, local_jumps =
     mk_failaction_neg partial ctx def in
   let lambda1 =
@@ -2248,24 +2259,24 @@ let combine_constant arg cst partial ctx def
             | _ -> assert false)
             const_lambda_list in
         let hs,sw,fail = share_actions_tree sw fail in
-        hs (Lstringswitch (arg,sw,fail))
+        hs (Lstringswitch (arg,sw,fail,loc))
     | Const_float _ ->
-        make_test_sequence
+        make_test_sequence loc
           fail
           (Pfloatcomp Cneq) (Pfloatcomp Clt)
           arg const_lambda_list
     | Const_int32 _ ->
-        make_test_sequence
+        make_test_sequence loc
           fail
           (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt))
           arg const_lambda_list
     | Const_int64 _ ->
-        make_test_sequence
+        make_test_sequence loc
           fail
           (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt))
           arg const_lambda_list
     | Const_nativeint _ ->
-        make_test_sequence
+        make_test_sequence loc
           fail
           (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt))
           arg const_lambda_list
@@ -2281,7 +2292,8 @@ let split_cases tag_lambda_list =
         match cstr with
           Cstr_constant n -> ((n, act) :: consts, nonconsts)
         | Cstr_block n    -> (consts, (n, act) :: nonconsts)
-        | _ -> assert false in
+        | Cstr_unboxed    -> (consts, (0, act) :: nonconsts)
+        | Cstr_extension _ -> assert false in
   let const, nonconst = split_rec tag_lambda_list in
   sort_int_lambda_list const,
   sort_int_lambda_list nonconst
@@ -2298,7 +2310,7 @@ let split_extension_cases tag_lambda_list =
   split_rec tag_lambda_list
 
 
-let combine_constructor arg ex_pat cstr partial ctx def
+let combine_constructor loc arg ex_pat cstr partial ctx def
     (tag_lambda_list, total1, pats) =
   if cstr.cstr_consts < 0 then begin
     (* Special cases for extensions *)
@@ -2325,17 +2337,17 @@ let combine_constructor arg ex_pat cstr partial ctx def
                 (fun (path, act) rem ->
                    Lifthenelse(Lprim(Pintcomp Ceq,
                                      [Lvar tag;
-                                      transl_path ex_pat.pat_env path]),
+                                      transl_path ex_pat.pat_env path], loc),
                                act, rem))
                 nonconsts
                 default
             in
-              Llet(Alias, tag, Lprim(Pfield 0, [arg]), tests)
+              Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests)
       in
         List.fold_right
           (fun (path, act) rem ->
              Lifthenelse(Lprim(Pintcomp Ceq,
-                               [arg; transl_path ex_pat.pat_env path]),
+                               [arg; transl_path ex_pat.pat_env path], loc),
                          act, rem))
           consts
           nonconst_lambda
@@ -2379,7 +2391,7 @@ let combine_constructor arg ex_pat cstr partial ctx def
               match act0 with
               | Some act ->
                   Lifthenelse
-                    (Lprim (Pisint, [arg]),
+                    (Lprim (Pisint, [arg], loc),
                      call_switcher
                        fail_opt arg
                        0 (n-1) consts,
@@ -2405,13 +2417,14 @@ let call_switcher_variant_constant fail arg int_lambda_list =
   call_switcher fail arg min_int max_int int_lambda_list
 
 
-let call_switcher_variant_constr fail arg int_lambda_list =
+let call_switcher_variant_constr loc fail arg int_lambda_list =
   let v = Ident.create "variant" in
-  Llet(Alias, v, Lprim(Pfield 0, [arg]),
+  Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc),
        call_switcher
          fail (Lvar v) min_int max_int int_lambda_list)
 
-let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
+let combine_variant loc row arg partial ctx def
+                    (tag_lambda_list, total1, _pats) =
   let row = Btype.row_repr row in
   let num_constr = ref 0 in
   if row.row_closed then
@@ -2424,7 +2437,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
   else
     num_constr := max_int;
   let test_int_or_block arg if_int if_block =
-    Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in
+    Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in
   let sig_complete =  List.length tag_lambda_list = !num_constr
   and one_action = same_actions tag_lambda_list in
   let fail, local_jumps =
@@ -2439,12 +2452,12 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
   | None, Some act -> act
   | _,_ ->
       match (consts, nonconsts) with
-      | ([n, act1], [m, act2]) when fail=None ->
+      | ([_, act1], [_, act2]) when fail=None ->
           test_int_or_block arg act1 act2
       | (_, []) -> (* One can compare integers and pointers *)
           make_test_sequence_variant_constant fail arg consts
       | ([], _) ->
-          let lam = call_switcher_variant_constr
+          let lam = call_switcher_variant_constr loc
               fail arg nonconsts in
           (* One must not dereference integers *)
           begin match fail with
@@ -2456,15 +2469,15 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) =
             call_switcher_variant_constant
               fail arg consts
           and lam_nonconst =
-            call_switcher_variant_constr
+            call_switcher_variant_constr loc
               fail arg nonconsts in
           test_int_or_block arg lam_const lam_nonconst
   in
   lambda1, jumps_union local_jumps total1
 
 
-let combine_array arg kind partial ctx def
-    (len_lambda_list, total1, pats)  =
+let combine_array loc arg kind partial ctx def
+    (len_lambda_list, total1, _pats)  =
   let fail, local_jumps = mk_failaction_neg partial  ctx def in
   let lambda1 =
     let newvar = Ident.create "len" in
@@ -2473,7 +2486,7 @@ let combine_array arg kind partial ctx def
         fail (Lvar newvar)
         0 max_int len_lambda_list in
     bind
-      Alias newvar (Lprim(Parraylength kind, [arg])) switch in
+      Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in
   lambda1, jumps_union local_jumps total1
 
 (* Insertion of debugging events *)
@@ -2488,10 +2501,10 @@ let rec event_branch repr lam =
                     lev_kind = ev.lev_kind;
                     lev_repr = repr;
                     lev_env = ev.lev_env})
-  | (Llet(str, id, lam, body), _) ->
-      Llet(str, id, lam, event_branch repr body)
+  | (Llet(str, k, id, lam, body), _) ->
+      Llet(str, k, id, lam, event_branch repr body)
   | Lstaticraise _,_ -> lam
-  | (_, Some r) ->
+  | (_, Some _) ->
       Printlambda.lambda Format.str_formatter lam ;
       fatal_error
         ("Matching.event_branch: "^Format.flush_str_formatter ())
@@ -2581,9 +2594,9 @@ let rec approx_present v = function
   | Lconst _ -> false
   | Lstaticraise (_,args) ->
       List.exists (fun lam -> approx_present v lam) args
-  | Lprim (_,args) ->
+  | Lprim (_,args,_) ->
       List.exists (fun lam -> approx_present v lam) args
-  | Llet (Alias, _, l1, l2) ->
+  | Llet (Alias, _k, _, l1, l2) ->
       approx_present v l1 || approx_present v l2
   | Lvar vv -> Ident.same v vv
   | _ -> true
@@ -2607,11 +2620,11 @@ let rec lower_bind v arg lam = match lam with
 | Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
     when not (approx_present v ls) ->
       Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]})
-| Llet (Alias, vv, lv, l) ->
+| Llet (Alias, k, vv, lv, l) ->
     if approx_present v lv then
       bind Alias v arg lam
     else
-      Llet (Alias, vv, lv, lower_bind v arg l)
+      Llet (Alias, k, vv, lv, lower_bind v arg l)
 | _ ->
     bind Alias v arg lam
 
@@ -2663,10 +2676,10 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs =
 (* To find reasonable names for variables *)
 
 let rec name_pattern default = function
-    (pat :: patl, action) :: rem ->
+    (pat :: _, _) :: rem ->
       begin match pat.pat_desc with
         Tpat_var (id, _) -> id
-      | Tpat_alias(p, id, _) -> id
+      | Tpat_alias(_, id, _) -> id
       | _ -> name_pattern default rem
       end
   | _ -> Ident.create default
@@ -2744,26 +2757,27 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
       compile_test
         (compile_match repr partial) partial
         divide_constant
-        (combine_constant arg cst partial)
+        (combine_constant pat.pat_loc arg cst partial)
         ctx pm
   | Tpat_construct (_, cstr, _) ->
       compile_test
         (compile_match repr partial) partial
-        divide_constructor (combine_constructor arg pat cstr partial)
+        divide_constructor
+        (combine_constructor pat.pat_loc arg pat cstr partial)
         ctx pm
   | Tpat_array _ ->
       let kind = Typeopt.array_pattern_kind pat in
       compile_test (compile_match repr partial) partial
-        (divide_array kind) (combine_array arg kind partial)
+        (divide_array kind) (combine_array pat.pat_loc arg kind partial)
         ctx pm
   | Tpat_lazy _ ->
       compile_no_test
         (divide_lazy (normalize_pat pat))
         ctx_combine repr partial ctx pm
-  | Tpat_variant(lab, _, row) ->
+  | Tpat_variant(_, _, row) ->
       compile_test (compile_match repr partial) partial
         (divide_variant !row)
-        (combine_variant !row arg partial)
+        (combine_variant pat.pat_loc !row arg partial)
         ctx pm
   | _ -> assert false
   end
@@ -2879,7 +2893,7 @@ let check_total total lambda i handler_fun =
     Lstaticcatch(lambda, (i,[]), handler_fun())
   end
 
-let compile_matching loc repr handler_fun arg pat_act_list partial =
+let compile_matching repr handler_fun arg pat_act_list partial =
   let partial = check_partial pat_act_list partial in
   match partial with
   | Partial ->
@@ -2907,24 +2921,24 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
 let partial_function loc () =
   (* [Location.get_pos_info] is too expensive *)
   let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
-  Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable),
+  Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None),
           [transl_normal_path Predef.path_match_failure;
            Lconst(Const_block(0,
               [Const_base(Const_string (fname, None));
                Const_base(Const_int line);
-               Const_base(Const_int char)]))])])
+               Const_base(Const_int char)]))], loc)], loc)
 
 let for_function loc repr param pat_act_list partial =
-  compile_matching loc repr (partial_function loc) param pat_act_list partial
+  compile_matching repr (partial_function loc) param pat_act_list partial
 
 (* In the following two cases, exhaustiveness info is not available! *)
 let for_trywith param pat_act_list =
-  compile_matching Location.none None
-    (fun () -> Lprim(Praise Raise_reraise, [param]))
+  compile_matching None
+    (fun () -> Lprim(Praise Raise_reraise, [param], Location.none))
     param pat_act_list Partial
 
 let simple_for_let loc param pat body =
-  compile_matching loc None (partial_function loc) param [pat, body] Partial
+  compile_matching None (partial_function loc) param [pat, body] Partial
 
 
 (* Optimize binding of immediate tuples
@@ -2976,7 +2990,7 @@ let simple_for_let loc param pat body =
 *)
 
 let rec map_return f = function
-  | Llet (k, id, l1, l2) -> Llet (k, id, l1, map_return f l2)
+  | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2)
   | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2)
   | Lifthenelse (lcond, lthen, lelse) ->
       Lifthenelse (lcond, map_return f lthen, map_return f lelse)
@@ -2985,7 +2999,7 @@ let rec map_return f = function
   | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2)
   | Lstaticcatch (l1, b, l2) ->
       Lstaticcatch (map_return f l1, b, map_return f l2)
-  | Lstaticraise _ | Lprim(Praise _, _) as l -> l
+  | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l
   | l -> f l
 
 (* The 'opt' reference indicates if the optimization is worthy.
@@ -3005,7 +3019,7 @@ let rec map_return f = function
 
 let assign_pat opt nraise catch_ids loc pat lam =
   let rec collect acc pat lam = match pat.pat_desc, lam with
-  | Tpat_tuple patl, Lprim(Pmakeblock _, lams) ->
+  | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) ->
       opt := true;
       List.fold_left2 collect acc patl lams
   | Tpat_tuple patl, Lconst(Const_block(_, scl)) ->
@@ -3043,9 +3057,10 @@ let for_let loc param pat body =
       (* This eliminates a useless variable (and stack slot in bytecode)
          for "let _ = ...". See #6865. *)
       Lsequence(param, body)
-  | Tpat_var _ ->
-      (* fast path *)
-      simple_for_let loc param pat body
+  | Tpat_var (id, _) ->
+      (* fast path, and keep track of simple bindings to unboxable numbers *)
+      let k = Typeopt.value_kind pat.pat_env pat.pat_type in
+      Llet(Strict, k, id, param, body)
   | _ ->
       let opt = ref false in
       let nraise = next_raise_count () in
@@ -3146,12 +3161,12 @@ let do_for_multiple_match loc paraml pat_act_list partial =
         let raise_num = next_raise_count () in
         raise_num,
         { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
-          args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
+          args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict];
           default = [[[omega]],raise_num] }
     | _ ->
         -1,
         { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
-          args = [Lprim(Pmakeblock(0, Immutable), paraml), Strict] ;
+          args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict];
           default = [] } in
 
   try

diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index 916479a81da40cfe841953357a2e1b9b0b751c80..f29901bd0c55d804b7b02e7b99ed4226e8ebe5fa 100644 (file)
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -41,6 +41,6 @@ val flatten_pattern: int -> pattern -> pattern list
 
 (* Expand stringswitch to  string test tree *)
 val expand_stringswitch:
-    lambda -> (string * lambda) list -> lambda option -> lambda
+    Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda
 
 val inline_lazy_force : lambda -> Location.t -> lambda

diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index fb7bdc00c3872136349cb0cec7ca85f03c5b8be9..945139208a6e8e0df3faa6a3511b8a7b59b4bb15 100644 (file)
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -54,6 +54,18 @@ let boxed_integer_name = function
   | Pint32 -> "int32"
   | Pint64 -> "int64"
 
+let value_kind = function
+  | Pgenval -> ""
+  | Pintval -> "[int]"
+  | Pfloatval -> "[float]"
+  | Pboxedintval bi -> Printf.sprintf "[%s]" (boxed_integer_name bi)
+
+let field_kind = function
+  | Pgenval -> "*"
+  | Pintval -> "int"
+  | Pfloatval -> "float"
+  | Pboxedintval bi -> boxed_integer_name bi
+
 let print_boxed_integer_conversion ppf bi1 bi2 =
   fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)
 
@@ -91,6 +103,8 @@ let record_rep ppf r =
   match r with
   | Record_regular -> fprintf ppf "regular"
   | Record_inlined i -> fprintf ppf "inlined(%i)" i
+  | Record_unboxed false -> fprintf ppf "unboxed"
+  | Record_unboxed true -> fprintf ppf "inlined(unboxed)"
   | Record_float -> fprintf ppf "float"
   | Record_extension -> fprintf ppf "ext"
 ;;
@@ -102,16 +116,32 @@ let string_of_loc_kind = function
   | Loc_POS -> "loc_POS"
   | Loc_LOC -> "loc_LOC"
 
+let block_shape ppf shape = match shape with
+  | None | Some [] -> ()
+  | Some l when List.for_all ((=) Pgenval) l -> ()
+  | Some [elt] ->
+      Format.fprintf ppf " (%s)" (field_kind elt)
+  | Some (h :: t) ->
+      Format.fprintf ppf " (%s" (field_kind h);
+      List.iter (fun elt ->
+          Format.fprintf ppf ",%s" (field_kind elt))
+        t;
+      Format.fprintf ppf ")"
+
 let primitive ppf = function
   | Pidentity -> fprintf ppf "id"
+  | Pbytes_to_string -> fprintf ppf "bytes_to_string"
+  | Pbytes_of_string -> fprintf ppf "bytes_of_string"
   | Pignore -> fprintf ppf "ignore"
-  | Prevapply _ -> fprintf ppf "revapply"
-  | Pdirapply _ -> fprintf ppf "dirapply"
+  | Prevapply -> fprintf ppf "revapply"
+  | Pdirapply -> fprintf ppf "dirapply"
   | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind)
   | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
   | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
-  | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag
-  | Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag
+  | Pmakeblock(tag, Immutable, shape) ->
+      fprintf ppf "makeblock %i%a" tag block_shape shape
+  | Pmakeblock(tag, Mutable, shape) ->
+      fprintf ppf "makemutable %i%a" tag block_shape shape
   | Pfield n -> fprintf ppf "field %i" n
   | Psetfield(n, ptr, init) ->
       let instr =
@@ -144,8 +174,10 @@ let primitive ppf = function
   | Paddint -> fprintf ppf "+"
   | Psubint -> fprintf ppf "-"
   | Pmulint -> fprintf ppf "*"
-  | Pdivint -> fprintf ppf "/"
-  | Pmodint -> fprintf ppf "mod"
+  | Pdivint Safe -> fprintf ppf "/"
+  | Pdivint Unsafe -> fprintf ppf "/u"
+  | Pmodint Safe -> fprintf ppf "mod"
+  | Pmodint Unsafe -> fprintf ppf "mod_unsafe"
   | Pandint -> fprintf ppf "and"
   | Porint -> fprintf ppf "or"
   | Pxorint -> fprintf ppf "xor"
@@ -176,9 +208,13 @@ let primitive ppf = function
   | Pfloatcomp(Cge) -> fprintf ppf ">=."
   | Pstringlength -> fprintf ppf "string.length"
   | Pstringrefu -> fprintf ppf "string.unsafe_get"
-  | Pstringsetu -> fprintf ppf "string.unsafe_set"
   | Pstringrefs -> fprintf ppf "string.get"
-  | Pstringsets -> fprintf ppf "string.set"
+  | Pbyteslength -> fprintf ppf "bytes.length"
+  | Pbytesrefu -> fprintf ppf "bytes.unsafe_get"
+  | Pbytessetu -> fprintf ppf "bytes.unsafe_set"
+  | Pbytesrefs -> fprintf ppf "bytes.get"
+  | Pbytessets -> fprintf ppf "bytes.set"
+
   | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k)
   | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k)
   | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k)
@@ -196,7 +232,8 @@ let primitive ppf = function
        | Max_wosize -> "max_wosize"
        | Ostype_unix -> "ostype_unix"
        | Ostype_win32 -> "ostype_win32"
-       | Ostype_cygwin -> "ostype_cygwin" in
+       | Ostype_cygwin -> "ostype_cygwin"
+       | Backend_type -> "backend_type" in
      fprintf ppf "sys.constant_%s" const_name
   | Pisint -> fprintf ppf "isint"
   | Pisout -> fprintf ppf "isout"
@@ -208,8 +245,14 @@ let primitive ppf = function
   | Paddbint bi -> print_boxed_integer "add" ppf bi
   | Psubbint bi -> print_boxed_integer "sub" ppf bi
   | Pmulbint bi -> print_boxed_integer "mul" ppf bi
-  | Pdivbint bi -> print_boxed_integer "div" ppf bi
-  | Pmodbint bi -> print_boxed_integer "mod" ppf bi
+  | Pdivbint { size = bi; is_safe = Safe } ->
+      print_boxed_integer "div" ppf bi
+  | Pdivbint { size = bi; is_safe = Unsafe } ->
+      print_boxed_integer "div_unsafe" ppf bi
+  | Pmodbint { size = bi; is_safe = Safe } ->
+      print_boxed_integer "mod" ppf bi
+  | Pmodbint { size = bi; is_safe = Unsafe } ->
+      print_boxed_integer "mod_unsafe" ppf bi
   | Pandbint bi -> print_boxed_integer "and" ppf bi
   | Porbint bi -> print_boxed_integer "or" ppf bi
   | Pxorbint bi -> print_boxed_integer "xor" ppf bi
@@ -222,9 +265,9 @@ let primitive ppf = function
   | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
   | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
   | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi
-  | Pbigarrayref(unsafe, n, kind, layout) ->
+  | Pbigarrayref(unsafe, _n, kind, layout) ->
       print_bigarray "get" unsafe kind ppf layout
-  | Pbigarrayset(unsafe, n, kind, layout) ->
+  | Pbigarrayset(unsafe, _n, kind, layout) ->
       print_bigarray "set" unsafe kind ppf layout
   | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
   | Pstring_load_16(unsafe) ->
@@ -270,9 +313,11 @@ let primitive ppf = function
 
 let name_of_primitive = function
   | Pidentity -> "Pidentity"
+  | Pbytes_of_string -> "Pbytes_of_string"
+  | Pbytes_to_string -> "Pbytes_to_string"
   | Pignore -> "Pignore"
-  | Prevapply _ -> "Prevapply"
-  | Pdirapply _ -> "Pdirapply"
+  | Prevapply -> "Prevapply"
+  | Pdirapply -> "Pdirapply"
   | Ploc _ -> "Ploc"
   | Pgetglobal _ -> "Pgetglobal"
   | Psetglobal _ -> "Psetglobal"
@@ -292,8 +337,8 @@ let name_of_primitive = function
   | Paddint -> "Paddint"
   | Psubint -> "Psubint"
   | Pmulint -> "Pmulint"
-  | Pdivint -> "Pdivint"
-  | Pmodint -> "Pmodint"
+  | Pdivint _ -> "Pdivint"
+  | Pmodint _ -> "Pmodint"
   | Pandint -> "Pandint"
   | Porint -> "Porint"
   | Pxorint -> "Pxorint"
@@ -314,9 +359,12 @@ let name_of_primitive = function
   | Pfloatcomp _ -> "Pfloatcomp"
   | Pstringlength -> "Pstringlength"
   | Pstringrefu -> "Pstringrefu"
-  | Pstringsetu -> "Pstringsetu"
   | Pstringrefs -> "Pstringrefs"
-  | Pstringsets -> "Pstringsets"
+  | Pbyteslength -> "Pbyteslength"
+  | Pbytesrefu -> "Pbytesrefu"
+  | Pbytessetu -> "Pbytessetu"
+  | Pbytesrefs -> "Pbytesrefs"
+  | Pbytessets -> "Pbytessets"
   | Parraylength _ -> "Parraylength"
   | Pmakearray _ -> "Pmakearray"
   | Pduparray _ -> "Pduparray"
@@ -422,16 +470,18 @@ let rec lam ppf = function
             fprintf ppf ")" in
       fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params
         function_attribute attr lam body
-  | Llet(str, id, arg, body) ->
+  | Llet(str, k, id, arg, body) ->
       let kind = function
-        Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in
+          Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v"
+      in
       let rec letbody = function
-        | Llet(str, id, arg, body) ->
-            fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg;
+        | Llet(str, k, id, arg, body) ->
+            fprintf ppf "@ @[<2>%a =%s%s@ %a@]"
+              Ident.print id (kind str) (value_kind k) lam arg;
             letbody body
         | expr -> expr in
-      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s@ %a@]"
-        Ident.print id (kind str) lam arg;
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s%s@ %a@]"
+        Ident.print id (kind str) (value_kind k) lam arg;
       let expr = letbody body in
       fprintf ppf ")@]@ %a)@]" lam expr
   | Lletrec(id_arg_list, body) ->
@@ -444,7 +494,7 @@ let rec lam ppf = function
           id_arg_list in
       fprintf ppf
         "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
-  | Lprim(prim, largs) ->
+  | Lprim(prim, largs, _) ->
       let lams ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs
@@ -471,7 +521,7 @@ let rec lam ppf = function
        "@[<1>(%s %a@ @[<v 0>%a@])@]"
        (match sw.sw_failaction with None -> "switch*" | _ -> "switch")
        lam larg switch sw
-  | Lstringswitch(arg, cases, default) ->
+  | Lstringswitch(arg, cases, default, _) ->
       let switch ppf cases =
         let spc = ref false in
         List.iter

diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli
index 7b81ce2d734a08ff9393964734da0ce0caf89e0f..daf0d81a08a9f10bac59d6da70f5b00718d07f8d 100644 (file)
--- a/bytecomp/printlambda.mli
+++ b/bytecomp/printlambda.mli
@@ -22,3 +22,4 @@ val lambda: formatter -> lambda -> unit
 val program: formatter -> program -> unit
 val primitive: formatter -> primitive -> unit
 val name_of_primitive : primitive -> string
+val value_kind : value_kind -> string

diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index fe1d005beaddeb931c5e758fd37edde34adc6822..4a66f71eed5fcb8f31e49720e523fff1d03f0d71 100644 (file)
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -26,27 +26,27 @@ exception Real_reference
 let rec eliminate_ref id = function
     Lvar v as lam ->
       if Ident.same v id then raise Real_reference else lam
-  | Lconst cst as lam -> lam
+  | Lconst _ as lam -> lam
   | Lapply ap ->
       Lapply{ap with ap_func = eliminate_ref id ap.ap_func;
                      ap_args = List.map (eliminate_ref id) ap.ap_args}
-  | Lfunction{kind; params; body} as lam ->
+  | Lfunction _ as lam ->
       if IdentSet.mem id (free_variables lam)
       then raise Real_reference
       else lam
-  | Llet(str, v, e1, e2) ->
-      Llet(str, v, eliminate_ref id e1, eliminate_ref id e2)
+  | Llet(str, kind, v, e1, e2) ->
+      Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2)
   | Lletrec(idel, e2) ->
       Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
               eliminate_ref id e2)
-  | Lprim(Pfield 0, [Lvar v]) when Ident.same v id ->
+  | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id ->
       Lvar id
-  | Lprim(Psetfield(0, _, _), [Lvar v; e]) when Ident.same v id ->
+  | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id ->
       Lassign(id, eliminate_ref id e)
-  | Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id ->
-      Lassign(id, Lprim(Poffsetint delta, [Lvar id]))
-  | Lprim(p, el) ->
-      Lprim(p, List.map (eliminate_ref id) el)
+  | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id ->
+      Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc))
+  | Lprim(p, el, loc) ->
+      Lprim(p, List.map (eliminate_ref id) el, loc)
   | Lswitch(e, sw) ->
       Lswitch(eliminate_ref id e,
         {sw_numconsts = sw.sw_numconsts;
@@ -57,11 +57,11 @@ let rec eliminate_ref id = function
             List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
          sw_failaction =
             Misc.may_map (eliminate_ref id) sw.sw_failaction; })
-  | Lstringswitch(e, sw, default) ->
+  | Lstringswitch(e, sw, default, loc) ->
       Lstringswitch
         (eliminate_ref id e,
          List.map (fun (s, e) -> (s, eliminate_ref id e)) sw,
-         Misc.may_map (eliminate_ref id) default)
+         Misc.may_map (eliminate_ref id) default, loc)
   | Lstaticraise (i,args) ->
       Lstaticraise (i,List.map (eliminate_ref id) args)
   | Lstaticcatch(e1, i, e2) ->
@@ -111,19 +111,19 @@ let simplify_exits lam =
   let rec count = function
   | (Lvar _| Lconst _) -> ()
   | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args
-  | Lfunction{kind; params; body = l} -> count l
-  | Llet(str, v, l1, l2) ->
+  | Lfunction {body} -> count body
+  | Llet(_str, _kind, _v, l1, l2) ->
       count l2; count l1
   | Lletrec(bindings, body) ->
-      List.iter (fun (v, l) -> count l) bindings;
+      List.iter (fun (_v, l) -> count l) bindings;
       count body
-  | Lprim(p, ll) -> List.iter count ll
+  | Lprim(_p, ll, _) -> List.iter count ll
   | Lswitch(l, sw) ->
       count_default sw ;
       count l;
       List.iter (fun (_, l) -> count l) sw.sw_consts;
       List.iter (fun (_, l) -> count l) sw.sw_blocks
-  | Lstringswitch(l, sw, d) ->
+  | Lstringswitch(l, sw, d, _) ->
       count l;
       List.iter (fun (_, l) -> count l) sw;
       begin match  d with
@@ -150,15 +150,15 @@ let simplify_exits lam =
          l2 will be removed, so don't count its exits *)
       if count_exit i > 0 then
         count l2
-  | Ltrywith(l1, v, l2) -> count l1; count l2
+  | Ltrywith(l1, _v, l2) -> count l1; count l2
   | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
   | Lsequence(l1, l2) -> count l1; count l2
   | Lwhile(l1, l2) -> count l1; count l2
-  | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3
-  | Lassign(v, l) -> count l
-  | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll)
+  | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3
+  | Lassign(_v, l) -> count l
+  | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll)
   | Levent(l, _) -> count l
-  | Lifused(v, l) -> count l
+  | Lifused(_v, l) -> count l
 
   and count_default sw = match sw.sw_failaction with
   | None -> ()
@@ -200,37 +200,37 @@ let simplify_exits lam =
   | Lapply ap ->
       Lapply{ap with ap_func = simplif ap.ap_func;
                      ap_args = List.map simplif ap.ap_args}
-  | Lfunction{kind; params; body = l; attr} ->
-     Lfunction{kind; params; body = simplif l; attr}
-  | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
+  | Lfunction{kind; params; body = l; attr; loc} ->
+     Lfunction{kind; params; body = simplif l; attr; loc}
+  | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2)
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
-  | Lprim(p, ll) -> begin
+  | Lprim(p, ll, loc) -> begin
     let ll = List.map simplif ll in
     match p, ll with
         (* Simplify %revapply, for n-ary functions with n > 1 *)
-      | Prevapply loc, [x; Lapply ap]
-      | Prevapply loc, [x; Levent (Lapply ap,_)] ->
+      | Prevapply, [x; Lapply ap]
+      | Prevapply, [x; Levent (Lapply ap,_)] ->
         Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
-      | Prevapply loc, [x; f] -> Lapply {ap_should_be_tailcall=false;
-                                         ap_loc=loc;
-                                         ap_func=f;
-                                         ap_args=[x];
-                                         ap_inlined=Default_inline;
-                                         ap_specialised=Default_specialise}
+      | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false;
+                                     ap_loc=loc;
+                                     ap_func=f;
+                                     ap_args=[x];
+                                     ap_inlined=Default_inline;
+                                     ap_specialised=Default_specialise}
 
         (* Simplify %apply, for n-ary functions with n > 1 *)
-      | Pdirapply loc, [Lapply ap; x]
-      | Pdirapply loc, [Levent (Lapply ap,_); x] ->
+      | Pdirapply, [Lapply ap; x]
+      | Pdirapply, [Levent (Lapply ap,_); x] ->
         Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
-      | Pdirapply loc, [f; x] -> Lapply {ap_should_be_tailcall=false;
-                                         ap_loc=loc;
-                                         ap_func=f;
-                                         ap_args=[x];
-                                         ap_inlined=Default_inline;
-                                         ap_specialised=Default_specialise}
-
-      | _ -> Lprim(p, ll)
+      | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false;
+                                     ap_loc=loc;
+                                     ap_func=f;
+                                     ap_args=[x];
+                                     ap_inlined=Default_inline;
+                                     ap_specialised=Default_specialise}
+
+      | _ -> Lprim(p, ll, loc)
      end
   | Lswitch(l, sw) ->
       let new_l = simplif l
@@ -241,10 +241,10 @@ let simplify_exits lam =
         (new_l,
          {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
                   sw_failaction = new_fail})
-  | Lstringswitch(l,sw,d) ->
+  | Lstringswitch(l,sw,d,loc) ->
       Lstringswitch
         (simplif l,List.map (fun (s,l) -> s,simplif l) sw,
-         Misc.may_map simplif d)
+         Misc.may_map simplif d,loc)
   | Lstaticraise (i,[]) as l ->
       begin try
         let _,handler =  Hashtbl.find subst i in
@@ -262,12 +262,12 @@ let simplify_exits lam =
             (fun x y t -> Ident.add x (Lvar y) t)
             xs ys Ident.empty in
         List.fold_right2
-          (fun y l r -> Llet (Alias, y, l, r))
+          (fun y l r -> Llet (Alias, Pgenval, y, l, r))
           ys ls (Lambda.subst_lambda env handler)
       with
       | Not_found -> Lstaticraise (i,ls)
       end
-  | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) ->
+  | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) ->
       Hashtbl.add subst i ([],simplif l2) ;
       simplif l1
   | Lstaticcatch (l1,(i,xs),l2) ->
@@ -302,7 +302,7 @@ let simplify_exits lam =
 *)
 
 let beta_reduce params body args =
-  List.fold_left2 (fun l param arg -> Llet(Strict, param, arg, l))
+  List.fold_left2 (fun l param arg -> Llet(Strict, Pgenval, param, arg, l))
                   body params args
 
 (* Simplification of lets *)
@@ -352,39 +352,39 @@ let simplify_lets lam =
       () in
 
   let rec count bv = function
-  | Lconst cst -> ()
+  | Lconst _ -> ()
   | Lvar v ->
       use_var bv v 1
   | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
     when optimize && List.length params = List.length args ->
       count bv (beta_reduce params body args)
   | Lapply{ap_func = Lfunction{kind = Tupled; params; body};
-           ap_args = [Lprim(Pmakeblock _, args)]}
+           ap_args = [Lprim(Pmakeblock _, args, _)]}
     when optimize && List.length params = List.length args ->
       count bv (beta_reduce params body args)
   | Lapply{ap_func = l1; ap_args = ll} ->
       count bv l1; List.iter (count bv) ll
-  | Lfunction{kind; params; body = l} ->
-      count Tbl.empty l
-  | Llet(str, v, Lvar w, l2) when optimize ->
+  | Lfunction {body} ->
+      count Tbl.empty body
+  | Llet(_str, _k, v, Lvar w, l2) when optimize ->
       (* v will be replaced by w in l2, so each occurrence of v in l2
          increases w's refcount *)
       count (bind_var bv v) l2;
       use_var bv w (count_var v)
-  | Llet(str, v, l1, l2) ->
+  | Llet(str, _kind, v, l1, l2) ->
       count (bind_var bv v) l2;
       (* If v is unused, l1 will be removed, so don't count its variables *)
       if str = Strict || count_var v > 0 then count bv l1
   | Lletrec(bindings, body) ->
-      List.iter (fun (v, l) -> count bv l) bindings;
+      List.iter (fun (_v, l) -> count bv l) bindings;
       count bv body
-  | Lprim(p, ll) -> List.iter (count bv) ll
+  | Lprim(_p, ll, _) -> List.iter (count bv) ll
   | Lswitch(l, sw) ->
       count_default bv sw ;
       count bv l;
       List.iter (fun (_, l) -> count bv l) sw.sw_consts;
       List.iter (fun (_, l) -> count bv l) sw.sw_blocks
-  | Lstringswitch(l, sw, d) ->
+  | Lstringswitch(l, sw, d, _) ->
       count bv l ;
       List.iter (fun (_, l) -> count bv l) sw ;
       begin match d with
@@ -395,14 +395,14 @@ let simplify_lets lam =
           end
       | None -> ()
       end
-  | Lstaticraise (i,ls) -> List.iter (count bv) ls
-  | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2
-  | Ltrywith(l1, v, l2) -> count bv l1; count bv l2
+  | Lstaticraise (_i,ls) -> List.iter (count bv) ls
+  | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2
+  | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2
   | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3
   | Lsequence(l1, l2) -> count bv l1; count bv l2
   | Lwhile(l1, l2) -> count Tbl.empty l1; count Tbl.empty l2
-  | Lfor(_, l1, l2, dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3
-  | Lassign(v, l) ->
+  | Lfor(_, l1, l2, _dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3
+  | Lassign(_v, l) ->
       (* Lalias-bound variables are never assigned, so don't increase
          v's refcount *)
       count bv l
@@ -435,9 +435,9 @@ let simplify_lets lam =
 (* This (small)  optimisation is always legal, it may uncover some
    tail call later on. *)
 
-  let mklet (kind,v,e1,e2) = match e2 with
+  let mklet str kind v e1 e2  = match e2 with
   | Lvar w when optimize && Ident.same v w -> e1
-  | _ -> Llet (kind,v,e1,e2) in
+  | _ -> Llet (str, kind,v,e1,e2) in
 
 
   let rec simplif = function
@@ -447,51 +447,57 @@ let simplify_lets lam =
       with Not_found ->
         l
       end
-  | Lconst cst as l -> l
+  | Lconst _ as l -> l
   | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
     when optimize && List.length params = List.length args ->
       simplif (beta_reduce params body args)
   | Lapply{ap_func = Lfunction{kind = Tupled; params; body};
-           ap_args = [Lprim(Pmakeblock _, args)]}
+           ap_args = [Lprim(Pmakeblock _, args, _)]}
     when optimize && List.length params = List.length args ->
       simplif (beta_reduce params body args)
   | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func;
                                  ap_args = List.map simplif ap.ap_args}
-  | Lfunction{kind; params; body = l; attr} ->
+  | Lfunction{kind; params; body = l; attr; loc} ->
       begin match simplif l with
-        Lfunction{kind=Curried; params=params'; body; attr}
+        Lfunction{kind=Curried; params=params'; body; attr; loc}
         when kind = Curried && optimize ->
-          Lfunction{kind; params = params @ params'; body; attr}
+          Lfunction{kind; params = params @ params'; body; attr; loc}
       | body ->
-          Lfunction{kind; params; body; attr}
+          Lfunction{kind; params; body; attr; loc}
       end
-  | Llet(str, v, Lvar w, l2) when optimize ->
+  | Llet(_str, _k, v, Lvar w, l2) when optimize ->
       Hashtbl.add subst v (simplif (Lvar w));
       simplif l2
-  | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody)
+  | Llet(Strict, kind, v,
+         Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody)
     when optimize ->
       let slinit = simplif linit in
       let slbody = simplif lbody in
       begin try
-       mklet (Variable, v, slinit, eliminate_ref v slbody)
+        let kind = match kind_ref with
+          | None -> Pgenval
+          | Some [field_kind] -> field_kind
+          | Some _ -> assert false
+        in
+        mklet Variable kind v slinit (eliminate_ref v slbody)
       with Real_reference ->
-        mklet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody)
+        mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody
       end
-  | Llet(Alias, v, l1, l2) ->
+  | Llet(Alias, kind, v, l1, l2) ->
       begin match count_var v with
         0 -> simplif l2
       | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2
-      | n -> Llet(Alias, v, simplif l1, simplif l2)
+      | _ -> Llet(Alias, kind, v, simplif l1, simplif l2)
       end
-  | Llet(StrictOpt, v, l1, l2) ->
+  | Llet(StrictOpt, kind, v, l1, l2) ->
       begin match count_var v with
         0 -> simplif l2
-      | n -> mklet(Alias, v, simplif l1, simplif l2)
+      | _ -> mklet Alias kind v (simplif l1) (simplif l2)
       end
-  | Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2)
+  | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2)
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
-  | Lprim(p, ll) -> Lprim(p, List.map simplif ll)
+  | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc)
   | Lswitch(l, sw) ->
       let new_l = simplif l
       and new_consts =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
@@ -501,10 +507,10 @@ let simplify_lets lam =
         (new_l,
          {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
                   sw_failaction = new_fail})
-  | Lstringswitch (l,sw,d) ->
+  | Lstringswitch (l,sw,d,loc) ->
       Lstringswitch
         (simplif l,List.map (fun (s,l) -> s,simplif l) sw,
-         Misc.may_map simplif d)
+         Misc.may_map simplif d,loc)
   | Lstaticraise (i,ls) ->
       Lstaticraise (i, List.map simplif ls)
   | Lstaticcatch(l1, (i,args), l2) ->
@@ -531,7 +537,7 @@ let simplify_lets lam =
 (* Tail call info in annotation files *)
 
 let is_tail_native_heuristic : (int -> bool) ref =
-  ref (fun n -> true)
+  ref (fun _ -> true)
 
 let rec emit_tail_infos is_tail lambda =
   let call_kind args =
@@ -554,26 +560,26 @@ let rec emit_tail_infos is_tail lambda =
         Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args))
   | Lfunction {body = lam} ->
       emit_tail_infos true lam
-  | Llet (_, _, lam, body) ->
+  | Llet (_str, _k, _, lam, body) ->
       emit_tail_infos false lam;
       emit_tail_infos is_tail body
   | Lletrec (bindings, body) ->
       List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
       emit_tail_infos is_tail body
-  | Lprim (Pidentity, [arg]) ->
+  | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _) ->
       emit_tail_infos is_tail arg
-  | Lprim (Psequand, [arg1; arg2])
-  | Lprim (Psequor, [arg1; arg2]) ->
+  | Lprim (Psequand, [arg1; arg2], _)
+  | Lprim (Psequor, [arg1; arg2], _) ->
       emit_tail_infos false arg1;
       emit_tail_infos is_tail arg2
-  | Lprim (_, l) ->
+  | Lprim (_, l, _) ->
       list_emit_tail_infos false l
   | Lswitch (lam, sw) ->
       emit_tail_infos false lam;
       list_emit_tail_infos_fun snd is_tail sw.sw_consts;
       list_emit_tail_infos_fun snd is_tail sw.sw_blocks;
       Misc.may  (emit_tail_infos is_tail) sw.sw_failaction
-  | Lstringswitch (lam, sw, d) ->
+  | Lstringswitch (lam, sw, d, _) ->
       emit_tail_infos false lam;
       List.iter
         (fun (_,lam) ->  emit_tail_infos is_tail lam)
@@ -627,14 +633,14 @@ and list_emit_tail_infos is_tail =
    function's body. *)
 
 let split_default_wrapper ?(create_wrapper_body = fun lam -> lam)
-      fun_id kind params body attr =
+      ~id:fun_id ~kind ~params ~body ~attr ~wrapper_attr ~loc () =
   let rec aux map = function
-    | Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
+    | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
         Ident.name optparam = "*opt*" && List.mem optparam params
           && not (List.mem_assoc optparam map)
       ->
         let wrapper_body, inner = aux ((optparam, id) :: map) rest in
-        Llet(Strict, id, def, wrapper_body), inner
+        Llet(Strict, k, id, def, wrapper_body), inner
     | _ when map = [] -> raise Exit
     | body ->
         (* Check that those *opt* identifiers don't appear in the remaining
@@ -664,22 +670,27 @@ let split_default_wrapper ?(create_wrapper_body = fun lam -> lam)
         in
         let body = Lambda.subst_lambda subst body in
         let inner_fun =
-          Lfunction { kind = Curried; params = new_ids; body; attr; }
+          Lfunction { kind = Curried; params = new_ids; body; attr; loc; }
         in
         (wrapper_body, (inner_id, inner_fun))
   in
   try
     let wrapper_body, inner = aux [] body in
     [(fun_id, Lfunction{kind; params; body = create_wrapper_body wrapper_body;
-       attr}); inner]
+       attr = wrapper_attr; loc}); inner]
   with Exit ->
-    [(fun_id, Lfunction{kind; params; body; attr})]
+    [(fun_id, Lfunction{kind; params; body; attr; loc})]
+
+module Hooks = Misc.MakeHooks(struct
+    type t = lambda
+  end)
 
 (* The entry point:
    simplification + emission of tailcall annotations, if needed. *)
 
-let simplify_lambda lam =
+let simplify_lambda sourcefile lam =
   let res = simplify_lets (simplify_exits lam) in
+  let res = Hooks.apply_hooks { Misc.sourcefile } res in
   if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall
     then emit_tail_infos true res;
   res

diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli
index 65b8fb0337887a6088915afe5ec7e9f82ed3b6b9..6736ffc32508aa4728cef85d3799b925c106626c 100644 (file)
--- a/bytecomp/simplif.mli
+++ b/bytecomp/simplif.mli
@@ -20,17 +20,22 @@
 
 open Lambda
 
-val simplify_lambda: lambda -> lambda
+val simplify_lambda: string -> lambda -> lambda
 
 val split_default_wrapper
    : ?create_wrapper_body:(lambda -> lambda)
-  -> Ident.t
-  -> function_kind
-  -> Ident.t list
-  -> lambda
-  -> function_attribute
+  -> id:Ident.t
+  -> kind:function_kind
+  -> params:Ident.t list
+  -> body:lambda
+  -> attr:function_attribute
+  -> wrapper_attr:function_attribute
+  -> loc:Location.t
+  -> unit
   -> (Ident.t * lambda) list
 
 (* To be filled by asmcomp/selectgen.ml *)
 val is_tail_native_heuristic: (int -> bool) ref
                           (* # arguments -> can tailcall *)
+
+module Hooks : Misc.HookSig with type t = lambda

diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml
index dfcf77e398b938a9eecb6355db1745456c8d6108..fbde44521a730c23f1c591ce823ed1b68fb76e73 100644 (file)
--- a/bytecomp/switch.ml
+++ b/bytecomp/switch.ml
@@ -390,13 +390,13 @@ let rec opt_count top cases =
             if lcases < !cut then
               enum top cases
             else if lcases < !more_cut then
-              heuristic top cases
+              heuristic cases
             else
-              divide top cases in
+              divide cases in
       Hashtbl.add t key r ;
       r
 
-and divide top cases =
+and divide cases =
   let lcases = Array.length cases in
   let m = lcases/2 in
   let _,left,right = coupe cases m in
@@ -412,10 +412,10 @@ and divide top cases =
     add_test cm cml ;
   Sep m,(cm, ci)
 
-and heuristic top cases =
+and heuristic cases =
   let lcases = Array.length cases in
 
-  let sep,csep = divide false cases
+  let sep,csep = divide cases
 
   and inter,cinter =
     if !ok_inter then begin
@@ -589,7 +589,7 @@ and enum top cases =
 
       else begin
 
-        let w,c = opt_count false cases in
+        let w,_c = opt_count false cases in
 (*
   Printf.fprintf stderr
   "off=%d tactic=%a for %a\n"
@@ -664,13 +664,13 @@ let switch_min = ref 3
 (* Particular case 0, 1, 2 *)
 let particular_case cases i j =
   j-i = 2 &&
-  (let l1,h1,act1 = cases.(i)
-  and  l2,h2,act2 = cases.(i+1)
+  (let l1,_h1,act1 = cases.(i)
+  and  l2,_h2,_act2 = cases.(i+1)
   and  l3,h3,act3 = cases.(i+2) in
   l1+1=l2 && l2+1=l3 && l3=h3 &&
   act1 <> act3)
 
-let approx_count cases i j n_actions =
+let approx_count cases i j =
   let l = j-i+1 in
   if l < !cut then
      let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
@@ -680,12 +680,12 @@ let approx_count cases i j n_actions =
 
 (* Sends back a boolean that says whether is switch is worth or not *)
 
-let dense {cases=cases ; actions=actions} i j =
+let dense {cases} i j =
   if i=j then true
   else
     let l,_,_ = cases.(i)
     and _,h,_ = cases.(j) in
-    let ntests =  approx_count cases i j (Array.length actions) in
+    let ntests =  approx_count cases i j in
 (*
   (ntests+1) >= theta * (h-l+1)
 *)
@@ -701,8 +701,8 @@ let dense {cases=cases ; actions=actions} i j =
    Software Practice and Exprience Vol. 24(2) 233 (Feb 1994)
 *)
 
-let comp_clusters ({cases=cases ; actions=actions} as s) =
-  let len = Array.length cases in
+let comp_clusters s =
+  let len = Array.length s.cases in
   let min_clusters = Array.make len max_int
   and k = Array.make len 0 in
   let get_min i = if i < 0 then 0 else min_clusters.(i) in

diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 22810cfc1410ec6c478bb9888c8073e2391f1945..8e96f498b7cab4b53edd083e5d462b9a939ed051 100644 (file)
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -332,12 +332,12 @@ let check_global_initialized patchlist =
     List.fold_left
       (fun accu rel ->
         match rel with
-          (Reloc_setglobal id, pos) -> id :: accu
+          (Reloc_setglobal id, _pos) -> id :: accu
         | _ -> accu)
       [] patchlist in
   (* Then check that all referenced, not defined globals have a value *)
   let check_reference = function
-      (Reloc_getglobal id, pos) ->
+      (Reloc_getglobal id, _pos) ->
         if not (List.mem id defined_globals)
         && Obj.is_int (get_global_value id)
         then raise (Error(Uninitialized_global(Ident.name id)))

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index a24780998994803810e9d2e8ec5675096a614bfc..fe5a203f17aac63aa6de912c4bb1dfa32e430b57 100644 (file)
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -29,12 +29,14 @@ exception Error of Location.t * error
 let lfunction params body =
   if params = [] then body else
   match body with
-  | Lfunction {kind = Curried; params = params'; body = body'; attr} ->
-      Lfunction {kind = Curried; params = params @ params'; body = body'; attr}
+  | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} ->
+      Lfunction {kind = Curried; params = params @ params'; body = body'; attr;
+                 loc}
   |  _ ->
       Lfunction {kind = Curried; params;
                  body;
-                 attr = default_function_attribute}
+                 attr = default_function_attribute;
+                 loc = Location.none}
 
 let lapply ap =
   match ap.ap_func with
@@ -54,7 +56,7 @@ let mkappl (func, args) =
 let lsequence l1 l2 =
   if l2 = lambda_unit then l1 else Lsequence(l1, l2)
 
-let lfield v i = Lprim(Pfield i, [Lvar v])
+let lfield v i = Lprim(Pfield i, [Lvar v], Location.none)
 
 let transl_label l = share (Const_immstring l)
 
@@ -69,7 +71,7 @@ let set_inst_var obj id expr =
     | Pointer -> Paddrarray
     | Immediate -> Pintarray
   in
-  Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr])
+  Lprim(Parraysetu kind, [Lvar obj; Lvar id; transl_exp expr], Location.none)
 
 let transl_val tbl create name =
   mkappl (oo_prim (if create then "new_variable" else "get_variable"),
@@ -78,7 +80,7 @@ let transl_val tbl create name =
 let transl_vals tbl create strict vals rem =
   List.fold_right
     (fun (name, id) rem ->
-      Llet(strict, id, transl_val tbl create name, rem))
+      Llet(strict, Pgenval, id, transl_val tbl create name, rem))
     vals rem
 
 let meths_super tbl meths inh_meths =
@@ -93,7 +95,8 @@ let meths_super tbl meths inh_meths =
 
 let bind_super tbl (vals, meths) cl_init =
   transl_vals tbl false StrictOpt vals
-    (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem))
+    (List.fold_right (fun (_nm, id, def) rem ->
+         Llet(StrictOpt, Pgenval, id, def, rem))
        meths cl_init)
 
 let create_object cl obj init =
@@ -106,7 +109,7 @@ let create_object cl obj init =
              [obj; Lvar cl]))
   else begin
    (inh_init,
-    Llet(Strict, obj',
+    Llet(Strict, Pgenval, obj',
             mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
          Lsequence(obj_init,
                    if not has_init then Lvar obj' else
@@ -117,7 +120,7 @@ let create_object cl obj init =
 let name_pattern default p =
   match p.pat_desc with
   | Tpat_var (id, _) -> id
-  | Tpat_alias(p, id, _) -> id
+  | Tpat_alias(_, id, _) -> id
   | _ -> Ident.create default
 
 let normalize_cl_path cl path =
@@ -130,7 +133,10 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
       let envs, inh_init = inh_init in
       let env =
         match envs with None -> []
-        | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
+        | Some envs ->
+            [Lprim(Pfield (List.length inh_init + 1),
+                   [Lvar envs],
+                   Location.none)]
       in
       ((envs, (obj_init, normalize_cl_path cl path)
         ::inh_init),
@@ -174,6 +180,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
          let param = name_pattern "param" pat in
          Lfunction {kind = Curried; params = param::params;
                     attr = default_function_attribute;
+                    loc = pat.pat_loc;
                     body = Matching.for_function
                              pat.pat_loc None (Lvar param) [pat, rem] partial}
        in
@@ -192,12 +199,12 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
         build_object_init cl_table obj (vals @ params) inh_init obj_init cl
       in
       (inh_init, Translcore.transl_let rec_flag defs obj_init)
-  | Tcl_constraint (cl, _, vals, pub_meths, concr_meths) ->
+  | Tcl_constraint (cl, _, _vals, _pub_meths, _concr_meths) ->
       build_object_init cl_table obj params inh_init obj_init cl
 
 let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
   match cl.cl_desc with
-    Tcl_let (rec_flag, defs, vals, cl) ->
+    Tcl_let (_rec_flag, _defs, vals, cl) ->
       let vals = List.map (fun (id, _, e) -> id,e) vals in
       build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
   | _ ->
@@ -206,14 +213,14 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
       let obj = if ids = [] then lambda_unit else Lvar self in
       let envs = if top then None else Some env in
       let ((_,inh_init), obj_init) =
-        build_object_init cl_table obj params (envs,[]) (copy_env env) cl in
+        build_object_init cl_table obj params (envs,[]) copy_env cl in
       let obj_init =
         if ids = [] then obj_init else lfunction [self] obj_init in
       (inh_init, lfunction [env] (subst_env env inh_init obj_init))
 
 
 let bind_method tbl lab id cl_init =
-  Llet(Strict, id, mkappl (oo_prim "get_method_label",
+  Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label",
                            [Lvar tbl; transl_label lab]),
        cl_init)
 
@@ -228,11 +235,12 @@ let bind_methods tbl meths vals cl_init =
     if nvals = 0 then "get_method_labels", [] else
     "new_methods_variables", [transl_meth_list (List.map fst vals)]
   in
-  Llet(Strict, ids,
+  Llet(Strict, Pgenval, ids,
        mkappl (oo_prim getter,
                [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
        List.fold_right
-         (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
+         (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id,
+                                           lfield ids !i, lam))
          (methl @ vals) cl_init)
 
 let output_methods tbl methods lam =
@@ -242,7 +250,8 @@ let output_methods tbl methods lam =
       lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
   | _ ->
       lsequence (mkappl(oo_prim "set_methods",
-                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
+                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None),
+                                         methods, Location.none)]))
         lam
 
 let rec ignore_cstrs cl =
@@ -262,12 +271,13 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
   match cl.cl_desc with
     Tcl_ident ( path, _, _) ->
       begin match inh_init with
-        (obj_init, path')::inh_init ->
+        (obj_init, _path')::inh_init ->
           let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in
           (inh_init,
-           Llet (Strict, obj_init,
-                 mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
-                        if top then [Lprim(Pfield 3, [lpath])] else []),
+           Llet (Strict, Pgenval, obj_init,
+                 mkappl(Lprim(Pfield 1, [lpath], Location.none), Lvar cla ::
+                        if top then [Lprim(Pfield 3, [lpath], Location.none)]
+                        else []),
                  bind_super cla super cl_init))
       | _ ->
           assert false
@@ -300,7 +310,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
                   if !Clflags.native_code && List.length met_code = 1 then
                     (* Force correct naming of method for profiles *)
                     let met = Ident.create ("method_" ^ name.txt) in
-                    [Llet(Strict, met, List.hd met_code, Lvar met)]
+                    [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)]
                   else met_code
                 in
                 (inh_init, cl_init,
@@ -319,15 +329,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
       in
       let cl_init = output_methods cla methods cl_init in
       (inh_init, bind_methods cla str.cstr_meths values cl_init)
-  | Tcl_fun (_, pat, vals, cl, _) ->
+  | Tcl_fun (_, _pat, vals, cl, _) ->
       let (inh_init, cl_init) =
         build_class_init cla cstr super inh_init cl_init msubst top cl
       in
       let vals = List.map bind_id_as_val vals in
       (inh_init, transl_vals cla true StrictOpt vals cl_init)
-  | Tcl_apply (cl, exprs) ->
+  | Tcl_apply (cl, _exprs) ->
       build_class_init cla cstr super inh_init cl_init msubst top cl
-  | Tcl_let (rec_flag, defs, vals, cl) ->
+  | Tcl_let (_rec_flag, _defs, vals, cl) ->
       let (inh_init, cl_init) =
         build_class_init cla cstr super inh_init cl_init msubst top cl
       in
@@ -353,19 +363,21 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
           let cl_init =
             List.fold_left
               (fun init (nm, id, _) ->
-                Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
+                Llet(StrictOpt, Pgenval, id,
+                     lfield inh (index nm concr_meths + ofs),
                      init))
               cl_init methids in
           let cl_init =
             List.fold_left
               (fun init (nm, id) ->
-                Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
+                Llet(StrictOpt, Pgenval, id,
+                     lfield inh (index nm vals + 1), init))
               cl_init valids in
           (inh_init,
-           Llet (Strict, inh,
+           Llet (Strict, Pgenval, inh,
                  mkappl(oo_prim "inherits", narrow_args @
                         [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
-                 Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
+                 Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
       | _ ->
           let core cl_init =
             build_class_init cla true super inh_init cl_init msubst top cl
@@ -381,7 +393,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
 
 let rec build_class_lets cl ids =
   match cl.cl_desc with
-    Tcl_let (rec_flag, defs, vals, cl') ->
+    Tcl_let (rec_flag, defs, _vals, cl') ->
       let env, wrap = build_class_lets cl' [] in
       (env, fun x ->
         let lam = Translcore.transl_let rec_flag defs (wrap x) in
@@ -420,6 +432,7 @@ let rec transl_class_rebind obj_init cl vf =
         let param = name_pattern "param" pat in
         Lfunction {kind = Curried; params = param::params;
                    attr = default_function_attribute;
+                   loc = pat.pat_loc;
                    body = Matching.for_function
                             pat.pat_loc None (Lvar param) [pat, rem] partial}
       in
@@ -430,7 +443,7 @@ let rec transl_class_rebind obj_init cl vf =
   | Tcl_apply (cl, oexprs) ->
       let path, obj_init = transl_class_rebind obj_init cl vf in
       (path, transl_apply obj_init oexprs Location.none)
-  | Tcl_let (rec_flag, defs, vals, cl) ->
+  | Tcl_let (rec_flag, defs, _vals, cl) ->
       let path, obj_init = transl_class_rebind obj_init cl vf in
       (path, Translcore.transl_let rec_flag defs obj_init)
   | Tcl_structure _ -> raise Exit
@@ -446,7 +459,7 @@ let rec transl_class_rebind obj_init cl vf =
 
 let rec transl_class_rebind_0 self obj_init cl vf =
   match cl.cl_desc with
-    Tcl_let (rec_flag, defs, vals, cl) ->
+    Tcl_let (rec_flag, defs, _vals, cl) ->
       let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
       (path, Translcore.transl_let rec_flag defs obj_init)
   | _ ->
@@ -477,19 +490,20 @@ let transl_class_rebind ids cl vf =
     and table = Ident.create "table"
     and envs = Ident.create "envs" in
     Llet(
-    Strict, new_init, lfunction [obj_init] obj_init',
+    Strict, Pgenval, new_init, lfunction [obj_init] obj_init',
     Llet(
-    Alias, cla, transl_normal_path path,
-    Lprim(Pmakeblock(0, Immutable),
+    Alias, Pgenval, cla, transl_normal_path path,
+    Lprim(Pmakeblock(0, Immutable, None),
           [mkappl(Lvar new_init, [lfield cla 0]);
            lfunction [table]
-             (Llet(Strict, env_init,
+             (Llet(Strict, Pgenval, env_init,
                    mkappl(lfield cla 1, [Lvar table]),
                    lfunction [envs]
                      (mkappl(Lvar new_init,
                              [mkappl(Lvar env_init, [Lvar envs])]))));
            lfield cla 2;
-           lfield cla 3])))
+           lfield cla 3],
+          Location.none)))
   with Exit ->
     lambda_unit
 
@@ -498,9 +512,9 @@ let transl_class_rebind ids cl vf =
 let rec module_path = function
     Lvar id ->
       let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
-  | Lprim(Pfield _, [p])    -> module_path p
-  | Lprim(Pgetglobal _, []) -> true
-  | _                       -> false
+  | Lprim(Pfield _, [p], _)    -> module_path p
+  | Lprim(Pgetglobal _, [], _) -> true
+  | _                          -> false
 
 let const_path local = function
     Lvar id -> not (List.mem id local)
@@ -515,16 +529,16 @@ let rec builtin_meths self env env2 body =
   let conv = function
     (* Lvar s when List.mem s self ->  "_self", [] *)
     | p when const_path p -> "const", [p]
-    | Lprim(Parrayrefu _, [Lvar s; Lvar n]) when List.mem s self ->
+    | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
         "var", [Lvar n]
-    | Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
+    | Lprim(Pfield n, [Lvar e], _) when Ident.same e env ->
         "env", [Lvar env2; Lconst(Const_pointer n)]
     | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
         "meth", [met]
     | _ -> raise Not_found
   in
   match body with
-  | Llet(_, s', Lvar s, body) when List.mem s self ->
+  | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
       builtin_meths (s'::self) env env2 body
   | Lapply{ap_func = f; ap_args = [arg]} when const_path f ->
       let s, args = conv arg in ("app_"^s, f :: args)
@@ -547,10 +561,10 @@ let rec builtin_meths self env env2 body =
       ("send_"^s, met :: args)
   | Lfunction {kind = Curried; params = [x]; body} ->
       let rec enter self = function
-        | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'])
+        | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _)
           when Ident.same x x' && List.mem s self ->
             ("set_var", [Lvar n])
-        | Llet(_, s', Lvar s, body) when List.mem s self ->
+        | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
             enter (s'::self) body
         | _ -> raise Not_found
       in enter self body
@@ -669,24 +683,27 @@ let transl_class ids cl_id pub_meths cl vflag =
         with Not_found ->
           [lfunction (self :: args)
              (if not (IdentSet.mem env (free_variables body')) then body' else
-              Llet(Alias, env,
+              Llet(Alias, Pgenval, env,
                    Lprim(Parrayrefu Paddrarray,
-                         [Lvar self; Lvar env2]), body'))]
+                         [Lvar self; Lvar env2],
+                         Location.none),
+                   body'))]
         end
       | _ -> assert false
   in
   let new_ids_init = ref [] in
   let env1 = Ident.create "env" and env1' = Ident.create "env'" in
-  let copy_env envs self =
+  let copy_env self =
     if top then lambda_unit else
     Lifused(env2, Lprim(Parraysetu Paddrarray,
-                        [Lvar self; Lvar env2; Lvar env1']))
+                        [Lvar self; Lvar env2; Lvar env1'],
+                        Location.none))
   and subst_env envs l lam =
     if top then lam else
     (* must be called only once! *)
     let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in
-    Llet(Alias, env1, (if l = [] then Lvar envs else lfield envs 0),
-    Llet(Alias, env1',
+    Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0),
+    Llet(Alias, Pgenval, env1',
          (if !new_ids_init = [] then Lvar env1 else lfield env1 0),
          lam))
   in
@@ -716,10 +733,10 @@ let transl_class ids cl_id pub_meths cl vflag =
       if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
     tags pub_meths;
   let ltable table lam =
-    Llet(Strict, table,
+    Llet(Strict, Pgenval, table,
          mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
   and ldirect obj_init =
-    Llet(Strict, obj_init, cl_init,
+    Llet(Strict, Pgenval, obj_init, cl_init,
          Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
                    mkappl (Lvar obj_init, [lambda_unit])))
   in
@@ -730,8 +747,9 @@ let transl_class ids cl_id pub_meths cl vflag =
   and lclass lam =
     let cl_init = llets (Lfunction{kind = Curried;
                                    attr = default_function_attribute;
+                                   loc = Location.none;
                                    params = [cla]; body = cl_init}) in
-    Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
+    Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
   and lbody fv =
     if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
       mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
@@ -739,18 +757,21 @@ let transl_class ids cl_id pub_meths cl vflag =
     else
       ltable table (
       Llet(
-      Strict, env_init, mkappl (Lvar class_init, [Lvar table]),
+      Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]),
       Lsequence(
       mkappl (oo_prim "init_class", [Lvar table]),
-      Lprim(Pmakeblock(0, Immutable),
+      Lprim(Pmakeblock(0, Immutable, None),
             [mkappl (Lvar env_init, [lambda_unit]);
-             Lvar class_init; Lvar env_init; lambda_unit]))))
+             Lvar class_init; Lvar env_init; lambda_unit],
+            Location.none))))
   and lbody_virt lenvs =
-    Lprim(Pmakeblock(0, Immutable),
+    Lprim(Pmakeblock(0, Immutable, None),
           [lambda_unit; Lfunction{kind = Curried;
                                   attr = default_function_attribute;
+                                  loc = Location.none;
                                   params = [cla]; body = cl_init};
-           lambda_unit; lenvs])
+           lambda_unit; lenvs],
+         Location.none)
   in
   (* Still easy: a class defined at toplevel *)
   if top && concrete then lclass lbody else
@@ -766,51 +787,63 @@ let transl_class ids cl_id pub_meths cl vflag =
   let lenv =
     let menv =
       if !new_ids_meths = [] then lambda_unit else
-      Lprim(Pmakeblock(0, Immutable),
-            List.map (fun id -> Lvar id) !new_ids_meths) in
+      Lprim(Pmakeblock(0, Immutable, None),
+            List.map (fun id -> Lvar id) !new_ids_meths,
+            Location.none) in
     if !new_ids_init = [] then menv else
-    Lprim(Pmakeblock(0, Immutable),
-          menv :: List.map (fun id -> Lvar id) !new_ids_init)
+    Lprim(Pmakeblock(0, Immutable, None),
+          menv :: List.map (fun id -> Lvar id) !new_ids_init,
+          Location.none)
   and linh_envs =
-    List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p]))
+    List.map
+      (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p], Location.none))
       (List.rev inh_init)
   in
   let make_envs lam =
-    Llet(StrictOpt, envs,
+    Llet(StrictOpt, Pgenval, envs,
          (if linh_envs = [] then lenv else
-         Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)),
+         Lprim(Pmakeblock(0, Immutable, None),
+               lenv :: linh_envs, Location.none)),
          lam)
   and def_ids cla lam =
-    Llet(StrictOpt, env2,
+    Llet(StrictOpt, Pgenval, env2,
          mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
          lam)
   in
   let inh_paths =
     List.filter
-      (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
+      (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init
+  in
   let inh_keys =
-    List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in
+    List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p],
+                                 Location.none))
+      inh_paths
+  in
   let lclass lam =
-    Llet(Strict, class_init,
+    Llet(Strict, Pgenval, class_init,
          Lfunction{kind = Curried; params = [cla];
                    attr = default_function_attribute;
+                   loc = Location.none;
                    body = def_ids cla cl_init}, lam)
   and lcache lam =
-    if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
-    Llet(Strict, cached,
+    if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else
+    Llet(Strict, Pgenval, cached,
          mkappl (oo_prim "lookup_tables",
-                [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
+                [Lvar tables; Lprim(Pmakeblock(0, Immutable, None),
+                                    inh_keys, Location.none)]),
          lam)
   and lset cached i lam =
-    Lprim(Psetfield(i, Pointer, Assignment), [Lvar cached; lam])
+    Lprim(Psetfield(i, Pointer, Assignment),
+          [Lvar cached; lam], Location.none)
   in
   let ldirect () =
     ltable cla
-      (Llet(Strict, env_init, def_ids cla cl_init,
+      (Llet(Strict, Pgenval, env_init, def_ids cla cl_init,
             Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
                       lset cached 0 (Lvar env_init))))
   and lclass_virt () =
     lset cached 0 (Lfunction{kind = Curried; attr = default_function_attribute;
+                             loc = Location.none;
                              params = [cla]; body = def_ids cla cl_init})
   in
   llets (
@@ -825,13 +858,14 @@ let transl_class ids cl_id pub_meths cl vflag =
                        Lvar class_init; Lvar cached]))),
   make_envs (
   if ids = [] then mkappl (lfield cached 0, [lenvs]) else
-  Lprim(Pmakeblock(0, Immutable),
-        if concrete then
+  Lprim(Pmakeblock(0, Immutable, None),
+        (if concrete then
           [mkappl (lfield cached 0, [lenvs]);
            lfield cached 1;
            lfield cached 0;
            lenvs]
-        else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
+        else [lambda_unit; lfield cached 0; lambda_unit; lenvs]),
+        Location.none
        )))))
 
 (* Wrapper for class compilation *)

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 42d02702e2be0d7eec048580c177a8118484c5f4..8b30d9fe4af2711185aedd39b2932f5ccffce259 100644 (file)
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -37,13 +37,35 @@ let use_dup_for_constant_arrays_bigger_than = 4
 
 (* Forward declaration -- to be filled in by Translmod.transl_module *)
 let transl_module =
-  ref((fun cc rootpath modl -> assert false) :
+  ref((fun _cc _rootpath _modl -> assert false) :
       module_coercion -> Path.t option -> module_expr -> lambda)
 
 let transl_object =
-  ref (fun id s cl -> assert false :
+  ref (fun _id _s _cl -> assert false :
        Ident.t -> string list -> class_expr -> lambda)
 
+(* Compile an exception/extension definition *)
+
+let prim_fresh_oo_id =
+  Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
+
+let transl_extension_constructor env path ext =
+  let name =
+    match path, !Clflags.for_package with
+      None, _ -> Ident.name ext.ext_id
+    | Some p, None -> Path.name p
+    | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
+  in
+  let loc = ext.ext_loc in
+  match ext.ext_kind with
+    Text_decl _ ->
+      Lprim (Pmakeblock (Obj.object_tag, Immutable, None),
+        [Lconst (Const_base (Const_string (name, None)));
+         Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
+        loc)
+  | Text_rebind(path, _lid) ->
+      transl_path ~loc env path
+
 (* Translation of primitives *)
 
 let comparisons_table = create_hashtable 11 [
@@ -53,6 +75,8 @@ let comparisons_table = create_hashtable 11 [
        Pfloatcomp Ceq,
        Pccall(Primitive.simple ~name:"caml_string_equal" ~arity:2
                 ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_bytes_equal" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Ceq),
        Pbintcomp(Pint32, Ceq),
        Pbintcomp(Pint64, Ceq),
@@ -63,6 +87,8 @@ let comparisons_table = create_hashtable 11 [
        Pfloatcomp Cneq,
        Pccall(Primitive.simple ~name:"caml_string_notequal" ~arity:2
                 ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_bytes_notequal" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Cneq),
        Pbintcomp(Pint32, Cneq),
        Pbintcomp(Pint64, Cneq),
@@ -73,6 +99,8 @@ let comparisons_table = create_hashtable 11 [
        Pfloatcomp Clt,
        Pccall(Primitive.simple ~name:"caml_string_lessthan" ~arity:2
                 ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Clt),
        Pbintcomp(Pint32, Clt),
        Pbintcomp(Pint64, Clt),
@@ -83,6 +111,8 @@ let comparisons_table = create_hashtable 11 [
        Pfloatcomp Cgt,
        Pccall(Primitive.simple ~name:"caml_string_greaterthan" ~arity:2
                 ~alloc: false),
+       Pccall(Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2
+                ~alloc: false),
        Pbintcomp(Pnativeint, Cgt),
        Pbintcomp(Pint32, Cgt),
        Pbintcomp(Pint64, Cgt),
@@ -93,6 +123,8 @@ let comparisons_table = create_hashtable 11 [
        Pfloatcomp Cle,
        Pccall(Primitive.simple ~name:"caml_string_lessequal" ~arity:2
                 ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Cle),
        Pbintcomp(Pint32, Cle),
        Pbintcomp(Pint64, Cle),
@@ -103,6 +135,8 @@ let comparisons_table = create_hashtable 11 [
        Pfloatcomp Cge,
        Pccall(Primitive.simple ~name:"caml_string_greaterequal" ~arity:2
                 ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2
+                ~alloc:false),
        Pbintcomp(Pnativeint, Cge),
        Pbintcomp(Pint32, Cge),
        Pbintcomp(Pint64, Cge),
@@ -120,6 +154,8 @@ let comparisons_table = create_hashtable 11 [
        unboxed_compare "caml_float_compare" Unboxed_float,
        Pccall(Primitive.simple ~name:"caml_string_compare" ~arity:2
                 ~alloc:false),
+       Pccall(Primitive.simple ~name:"caml_bytes_compare" ~arity:2
+                ~alloc:false),
        unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint),
        unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32),
        unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64),
@@ -128,12 +164,21 @@ let comparisons_table = create_hashtable 11 [
 
 let primitives_table = create_hashtable 57 [
   "%identity", Pidentity;
+  "%bytes_to_string", Pbytes_to_string;
+  "%bytes_of_string", Pbytes_of_string;
   "%ignore", Pignore;
+  "%revapply", Prevapply;
+  "%apply", Pdirapply;
+  "%loc_LOC", Ploc Loc_LOC;
+  "%loc_FILE", Ploc Loc_FILE;
+  "%loc_LINE", Ploc Loc_LINE;
+  "%loc_POS", Ploc Loc_POS;
+  "%loc_MODULE", Ploc Loc_MODULE;
   "%field0", Pfield 0;
   "%field1", Pfield 1;
   "%setfield0", Psetfield(0, Pointer, Assignment);
-  "%makeblock", Pmakeblock(0, Immutable);
-  "%makemutable", Pmakeblock(0, Mutable);
+  "%makeblock", Pmakeblock(0, Immutable, None);
+  "%makemutable", Pmakeblock(0, Mutable, None);
   "%raise", Praise Raise_regular;
   "%reraise", Praise Raise_reraise;
   "%raise_notrace", Praise Raise_notrace;
@@ -141,6 +186,7 @@ let primitives_table = create_hashtable 57 [
   "%sequor", Psequor;
   "%boolnot", Pnot;
   "%big_endian", Pctconst Big_endian;
+  "%backend_type", Pctconst Backend_type;
   "%word_size", Pctconst Word_size;
   "%int_size", Pctconst Int_size;
   "%max_wosize", Pctconst Max_wosize;
@@ -153,8 +199,8 @@ let primitives_table = create_hashtable 57 [
   "%addint", Paddint;
   "%subint", Psubint;
   "%mulint", Pmulint;
-  "%divint", Pdivint;
-  "%modint", Pmodint;
+  "%divint", Pdivint Safe;
+  "%modint", Pmodint Safe;
   "%andint", Pandint;
   "%orint", Porint;
   "%xorint", Pxorint;
@@ -185,9 +231,14 @@ let primitives_table = create_hashtable 57 [
   "%gefloat", Pfloatcomp Cge;
   "%string_length", Pstringlength;
   "%string_safe_get", Pstringrefs;
-  "%string_safe_set", Pstringsets;
+  "%string_safe_set", Pbytessets;
   "%string_unsafe_get", Pstringrefu;
-  "%string_unsafe_set", Pstringsetu;
+  "%string_unsafe_set", Pbytessetu;
+  "%bytes_length", Pbyteslength;
+  "%bytes_safe_get", Pbytesrefs;
+  "%bytes_safe_set", Pbytessets;
+  "%bytes_unsafe_get", Pbytesrefu;
+  "%bytes_unsafe_set", Pbytessetu;
   "%array_length", Parraylength Pgenarray;
   "%array_safe_get", Parrayrefs Pgenarray;
   "%array_safe_set", Parraysets Pgenarray;
@@ -204,8 +255,8 @@ let primitives_table = create_hashtable 57 [
   "%nativeint_add", Paddbint Pnativeint;
   "%nativeint_sub", Psubbint Pnativeint;
   "%nativeint_mul", Pmulbint Pnativeint;
-  "%nativeint_div", Pdivbint Pnativeint;
-  "%nativeint_mod", Pmodbint Pnativeint;
+  "%nativeint_div", Pdivbint { size = Pnativeint; is_safe = Safe };
+  "%nativeint_mod", Pmodbint { size = Pnativeint; is_safe = Safe };
   "%nativeint_and", Pandbint Pnativeint;
   "%nativeint_or",  Porbint Pnativeint;
   "%nativeint_xor", Pxorbint Pnativeint;
@@ -218,8 +269,8 @@ let primitives_table = create_hashtable 57 [
   "%int32_add", Paddbint Pint32;
   "%int32_sub", Psubbint Pint32;
   "%int32_mul", Pmulbint Pint32;
-  "%int32_div", Pdivbint Pint32;
-  "%int32_mod", Pmodbint Pint32;
+  "%int32_div", Pdivbint { size = Pint32; is_safe = Safe };
+  "%int32_mod", Pmodbint { size = Pint32; is_safe = Safe };
   "%int32_and", Pandbint Pint32;
   "%int32_or",  Porbint Pint32;
   "%int32_xor", Pxorbint Pint32;
@@ -232,8 +283,8 @@ let primitives_table = create_hashtable 57 [
   "%int64_add", Paddbint Pint64;
   "%int64_sub", Psubbint Pint64;
   "%int64_mul", Pmulbint Pint64;
-  "%int64_div", Pdivbint Pint64;
-  "%int64_mod", Pmodbint Pint64;
+  "%int64_div", Pdivbint { size = Pint64; is_safe = Safe };
+  "%int64_mod", Pmodbint { size = Pint64; is_safe = Safe };
   "%int64_and", Pandbint Pint64;
   "%int64_or",  Porbint Pint64;
   "%int64_xor", Pxorbint Pint64;
@@ -305,22 +356,11 @@ let primitives_table = create_hashtable 57 [
   "%opaque", Popaque;
 ]
 
-let prim_obj_dup =
-  Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
-
-let find_primitive loc prim_name =
-  match prim_name with
-      "%revapply" -> Prevapply loc
-    | "%apply" -> Pdirapply loc
-    | "%loc_LOC" -> Ploc Loc_LOC
-    | "%loc_FILE" -> Ploc Loc_FILE
-    | "%loc_LINE" -> Ploc Loc_LINE
-    | "%loc_POS" -> Ploc Loc_POS
-    | "%loc_MODULE" -> Ploc Loc_MODULE
-    | name -> Hashtbl.find primitives_table name
+let find_primitive prim_name =
+  Hashtbl.find primitives_table prim_name
 
 let specialize_comparison table env ty =
-  let (gencomp, intcomp, floatcomp, stringcomp,
+  let (gencomp, intcomp, floatcomp, stringcomp, bytescomp,
            nativeintcomp, int32comp, int64comp, _) = table in
   match () with
   | () when is_base_type env ty Predef.path_int
@@ -328,6 +368,7 @@ let specialize_comparison table env ty =
          || (maybe_pointer_type env ty = Immediate)   -> intcomp
   | () when is_base_type env ty Predef.path_float     -> floatcomp
   | () when is_base_type env ty Predef.path_string    -> stringcomp
+  | () when is_base_type env ty Predef.path_bytes     -> bytescomp
   | () when is_base_type env ty Predef.path_nativeint -> nativeintcomp
   | () when is_base_type env ty Predef.path_int32     -> int32comp
   | () when is_base_type env ty Predef.path_int64     -> int64comp
@@ -336,19 +377,19 @@ let specialize_comparison table env ty =
 (* Specialize a primitive from available type information,
    raise Not_found if primitive is unknown  *)
 
-let specialize_primitive loc p env ty ~has_constant_constructor =
+let specialize_primitive p env ty ~has_constant_constructor =
   try
     let table = Hashtbl.find comparisons_table p.prim_name in
-    let (gencomp, intcomp, _, _, _, _, _, simplify_constant_constructor) =
+    let (gencomp, intcomp, _, _, _, _, _, _, simplify_constant_constructor) =
       table in
     if has_constant_constructor && simplify_constant_constructor then
       intcomp
     else
       match is_function_type env ty with
-      | Some (lhs,rhs) -> specialize_comparison table env lhs
+      | Some (lhs,_rhs) -> specialize_comparison table env lhs
       | None -> gencomp
   with Not_found ->
-    let p = find_primitive loc p.prim_name in
+    let p = find_primitive p.prim_name in
     (* Try strength reduction based on the type of the argument *)
     let params = match is_function_type env ty with
       | None -> []
@@ -357,7 +398,7 @@ let specialize_primitive loc p env ty ~has_constant_constructor =
         | Some (p2, _) -> [p1;p2]
     in
     match (p, params) with
-      (Psetfield(n, _, init), [p1; p2]) ->
+      (Psetfield(n, _, init), [_p1; p2]) ->
         Psetfield(n, maybe_pointer_type env p2, init)
     | (Parraylength Pgenarray, [p])   -> Parraylength(array_type_kind env p)
     | (Parrayrefu Pgenarray, p1 :: _) -> Parrayrefu(array_type_kind env p1)
@@ -372,12 +413,15 @@ let specialize_primitive loc p env ty ~has_constant_constructor =
        p1 :: _) ->
         let (k, l) = bigarray_type_kind_and_layout env p1 in
         Pbigarrayset(unsafe, n, k, l)
+    | (Pmakeblock(tag, mut, None), fields) ->
+        let shape = List.map (Typeopt.value_kind env) fields in
+        Pmakeblock(tag, mut, Some shape)
     | _ -> p
 
 (* Eta-expand a primitive *)
 
 let used_primitives = Hashtbl.create 7
-let add_used_primitive loc p env path =
+let add_used_primitive loc env path =
   match path with
     Some (Path.Pdot _ as path) ->
       let path = Env.normalize_path (Some loc) env path in
@@ -388,9 +432,9 @@ let add_used_primitive loc p env path =
 
 let transl_primitive loc p env ty path =
   let prim =
-    try specialize_primitive loc p env ty ~has_constant_constructor:false
+    try specialize_primitive p env ty ~has_constant_constructor:false
     with Not_found ->
-      add_used_primitive loc p env path;
+      add_used_primitive loc env path;
       Pccall p
   in
   match prim with
@@ -398,6 +442,7 @@ let transl_primitive loc p env ty path =
       let parm = Ident.create "prim" in
       Lfunction{kind = Curried; params = [parm];
                 body = Matching.inline_lazy_force (Lvar parm) Location.none;
+                loc = loc;
                 attr = default_function_attribute }
   | Ploc kind ->
     let lam = lam_of_loc kind loc in
@@ -407,7 +452,9 @@ let transl_primitive loc p env ty path =
         let param = Ident.create "prim" in
         Lfunction{kind = Curried; params = [param];
                   attr = default_function_attribute;
-                  body = Lprim(Pmakeblock(0, Immutable), [lam; Lvar param])}
+                  loc = loc;
+                  body = Lprim(Pmakeblock(0, Immutable, None),
+                               [lam; Lvar param], loc)}
       | _ -> assert false
     end
   | _ ->
@@ -416,7 +463,8 @@ let transl_primitive loc p env ty path =
       let params = make_params p.prim_arity in
       Lfunction{ kind = Curried; params;
                  attr = default_function_attribute;
-                 body = Lprim(prim, List.map (fun id -> Lvar id) params) }
+                 loc = loc;
+                 body = Lprim(prim, List.map (fun id -> Lvar id) params, loc) }
 
 let transl_primitive_application loc prim env ty path args =
   let prim_name = prim.prim_name in
@@ -428,11 +476,11 @@ let transl_primitive_application loc prim env ty path args =
       | [{exp_desc = Texp_variant(_, None)}; _] -> true
       | _ -> false
     in
-    specialize_primitive loc prim env ty ~has_constant_constructor
+    specialize_primitive prim env ty ~has_constant_constructor
   with Not_found ->
     if String.length prim_name > 0 && prim_name.[0] = '%' then
       raise(Error(loc, Unknown_builtin_primitive prim_name));
-    add_used_primitive loc prim env path;
+    add_used_primitive loc env path;
     Pccall prim
 
 
@@ -441,16 +489,16 @@ let transl_primitive_application loc prim env ty path args =
 let check_recursive_lambda idlist lam =
   let rec check_top idlist = function
     | Lvar v -> not (List.mem v idlist)
-    | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
+    | Llet _ as lam when check_recursive_recordwith idlist lam ->
         true
-    | Llet(str, id, arg, body) ->
+    | Llet(_str, _k, id, arg, body) ->
         check idlist arg && check_top (add_let id arg idlist) body
     | Lletrec(bindings, body) ->
         let idlist' = add_letrec bindings idlist in
-        List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
+        List.for_all (fun (_id, arg) -> check idlist' arg) bindings &&
         check_top idlist' body
-    | Lprim (Pmakearray (Pgenarray, _), args) -> false
-    | Lprim (Pmakearray (Pfloatarray, _), args) ->
+    | Lprim (Pmakearray (Pgenarray, _), _, _) -> false
+    | Lprim (Pmakearray (Pfloatarray, _), args, _) ->
         List.for_all (check idlist) args
     | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
     | Levent (lam, _) -> check_top idlist lam
@@ -458,19 +506,19 @@ let check_recursive_lambda idlist lam =
 
   and check idlist = function
     | Lvar _ -> true
-    | Lfunction{kind; params; body} -> true
-    | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam ->
+    | Lfunction _ -> true
+    | Llet _ as lam when check_recursive_recordwith idlist lam ->
         true
-    | Llet(str, id, arg, body) ->
+    | Llet(_str, _k, id, arg, body) ->
         check idlist arg && check (add_let id arg idlist) body
     | Lletrec(bindings, body) ->
         let idlist' = add_letrec bindings idlist in
-        List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
+        List.for_all (fun (_id, arg) -> check idlist' arg) bindings &&
         check idlist' body
-    | Lprim(Pmakeblock(tag, mut), args) ->
+    | Lprim(Pmakeblock _, args, _) ->
         List.for_all (check idlist) args
-    | Lprim (Pmakearray (Pfloatarray, _), _) -> false
-    | Lprim (Pmakearray _, args) ->
+    | Lprim (Pmakearray (Pfloatarray, _), _, _) -> false
+    | Lprim (Pmakearray _, args, _) ->
         List.for_all (check idlist) args
     | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2
     | Levent (lam, _) -> check idlist lam
@@ -491,13 +539,14 @@ let check_recursive_lambda idlist lam =
   (* reverse-engineering the code generated by transl_record case 2 *)
   (* If you change this, you probably need to change Bytegen.size_of_lambda. *)
   and check_recursive_recordwith idlist = function
-    | Llet (Strict, id1, Lprim (Pduprecord _, [e1]), body) ->
+    | Llet (Strict, _k, id1, Lprim (Pduprecord _, [e1], _), body) ->
        check_top idlist e1
        && check_recordwith_updates idlist id1 body
     | _ -> false
 
   and check_recordwith_updates idlist id1 = function
-    | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont)
+    | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1], _),
+                 cont)
         -> id2 = id1 && check idlist e1
            && check_recordwith_updates idlist id1 cont
     | Lvar id2 -> id2 = id1
@@ -524,7 +573,7 @@ let rec name_pattern default = function
   | {c_lhs=p; _} :: rem ->
       match p.pat_desc with
         Tpat_var (id, _) -> id
-      | Tpat_alias(p, id, _) -> id
+      | Tpat_alias(_, id, _) -> id
       | _ -> name_pattern default rem
 
 (* Push the default values under the functional abstractions *)
@@ -593,7 +642,7 @@ let rec push_defaults loc bindings cases partial =
 let event_before exp lam = match lam with
 | Lstaticraise (_,_) -> lam
 | _ ->
-  if !Clflags.debug
+  if !Clflags.debug && not !Clflags.native_code
   then Levent(lam, {lev_loc = exp.exp_loc;
                     lev_kind = Lev_before;
                     lev_repr = None;
@@ -601,7 +650,7 @@ let event_before exp lam = match lam with
   else lam
 
 let event_after exp lam =
-  if !Clflags.debug
+  if !Clflags.debug && not !Clflags.native_code
   then Levent(lam, {lev_loc = exp.exp_loc;
                     lev_kind = Lev_after exp.exp_type;
                     lev_repr = None;
@@ -609,7 +658,7 @@ let event_after exp lam =
   else lam
 
 let event_function exp lam =
-  if !Clflags.debug then
+  if !Clflags.debug && not !Clflags.native_code then
     let repr = Some (ref 0) in
     let (info, body) = lam repr in
     (info,
@@ -623,9 +672,9 @@ let event_function exp lam =
 let primitive_is_ccall = function
   (* Determine if a primitive is a Pccall or will be turned later into
      a C function call that may raise an exception *)
-  | Pccall _ | Pstringrefs | Pstringsets | Parrayrefs _ | Parraysets _ |
-    Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply _ |
-    Prevapply _ -> true
+  | Pccall _ | Pstringrefs  | Pbytesrefs | Pbytessets | Parrayrefs _ |
+    Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
+    Prevapply -> true
   | _ -> false
 
 (* Assertions *)
@@ -634,12 +683,12 @@ let assert_failed exp =
   let (fname, line, char) =
     Location.get_pos_info exp.exp_loc.Location.loc_start in
   Lprim(Praise Raise_regular, [event_after exp
-    (Lprim(Pmakeblock(0, Immutable),
+    (Lprim(Pmakeblock(0, Immutable, None),
           [transl_normal_path Predef.path_assert_failure;
            Lconst(Const_block(0,
               [Const_base(Const_string (fname, None));
                Const_base(Const_int line);
-               Const_base(Const_int char)]))]))])
+               Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc)
 ;;
 
 let rec cut n l =
@@ -671,17 +720,19 @@ and transl_exp0 e =
         let obj = Ident.create "obj" and meth = Ident.create "meth" in
         Lfunction{kind = Curried; params = [obj; meth];
                   attr = default_function_attribute;
+                  loc = e.exp_loc;
                   body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)}
       else if p.prim_name = "%sendcache" then
         let obj = Ident.create "obj" and meth = Ident.create "meth" in
         let cache = Ident.create "cache" and pos = Ident.create "pos" in
         Lfunction{kind = Curried; params = [obj; meth; cache; pos];
                   attr = default_function_attribute;
+                  loc = e.exp_loc;
                   body = Lsend(Cached, Lvar meth, Lvar obj,
                                [Lvar cache; Lvar pos], e.exp_loc)}
       else
         transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path)
-  | Texp_ident(path, _, {val_kind = Val_anc _}) ->
+  | Texp_ident(_, _, {val_kind = Val_anc _}) ->
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
       transl_path ~loc:e.exp_loc e.exp_env path
@@ -703,7 +754,8 @@ and transl_exp0 e =
         specialise = Translattribute.get_specialise_attribute e.exp_attributes;
       }
       in
-      Lfunction{kind; params; body; attr}
+      let loc = e.exp_loc in
+      Lfunction{kind; params; body; attr; loc}
   | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
                 exp_type = prim_type } as funct, oargs)
     when List.length oargs >= p.prim_arity
@@ -756,19 +808,19 @@ and transl_exp0 e =
               | _ ->
                   k
             in
-            wrap0 (Lprim(Praise k, [event_after arg1 targ]))
+            wrap0 (Lprim(Praise k, [event_after arg1 targ], e.exp_loc))
         | (Ploc kind, []) ->
           lam_of_loc kind e.exp_loc
         | (Ploc kind, [arg1]) ->
           let lam = lam_of_loc kind arg1.exp_loc in
-          Lprim(Pmakeblock(0, Immutable), lam :: argl)
+          Lprim(Pmakeblock(0, Immutable, None), lam :: argl, e.exp_loc)
         | (Ploc _, _) -> assert false
         | (_, _) ->
             begin match (prim, argl) with
             | (Plazyforce, [a]) ->
                 wrap (Matching.inline_lazy_force a e.exp_loc)
             | (Plazyforce, _) -> assert false
-            |_ -> let p = Lprim(prim, argl) in
+            |_ -> let p = Lprim(prim, argl, e.exp_loc) in
                if primitive_is_ccall prim then wrap p else wrap0 p
             end
       end
@@ -793,32 +845,34 @@ and transl_exp0 e =
       Ltrywith(transl_exp body, id,
                Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list))
   | Texp_tuple el ->
-      let ll = transl_list el in
+      let ll, shape = transl_list_with_shape el in
       begin try
         Lconst(Const_block(0, List.map extract_constant ll))
       with Not_constant ->
-        Lprim(Pmakeblock(0, Immutable), ll)
+        Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc)
       end
   | Texp_construct(_, cstr, args) ->
-      let ll = transl_list args in
+      let ll, shape = transl_list_with_shape args in
       if cstr.cstr_inlined <> None then begin match ll with
         | [x] -> x
         | _ -> assert false
       end else begin match cstr.cstr_tag with
         Cstr_constant n ->
           Lconst(Const_pointer n)
+      | Cstr_unboxed ->
+          (match ll with [v] -> v | _ -> assert false)
       | Cstr_block n ->
           begin try
             Lconst(Const_block(n, List.map extract_constant ll))
           with Not_constant ->
-            Lprim(Pmakeblock(n, Immutable), ll)
+            Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc)
           end
       | Cstr_extension(path, is_const) ->
           if is_const then
             transl_path e.exp_env path
           else
-            Lprim(Pmakeblock(0, Immutable),
-                  transl_path e.exp_env path :: ll)
+            Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),
+                  transl_path e.exp_env path :: ll, e.exp_loc)
       end
   | Texp_extension_constructor (_, path) ->
       transl_path e.exp_env path
@@ -832,33 +886,34 @@ and transl_exp0 e =
             Lconst(Const_block(0, [Const_base(Const_int tag);
                                    extract_constant lam]))
           with Not_constant ->
-            Lprim(Pmakeblock(0, Immutable),
-                  [Lconst(Const_base(Const_int tag)); lam])
+            Lprim(Pmakeblock(0, Immutable, None),
+                  [Lconst(Const_base(Const_int tag)); lam], e.exp_loc)
       end
-  | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
-      transl_record e.exp_env lbl1.lbl_all lbl1.lbl_repres lbl_expr_list
-        opt_init_expr
-  | Texp_record ([], _) ->
-      fatal_error "Translcore.transl_exp: bad Texp_record"
+  | Texp_record {fields; representation; extended_expression} ->
+      transl_record e.exp_loc e.exp_env fields representation
+        extended_expression
   | Texp_field(arg, _, lbl) ->
-      let access =
-        match lbl.lbl_repres with
-          Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos
-        | Record_float -> Pfloatfield lbl.lbl_pos
-        | Record_extension -> Pfield (lbl.lbl_pos + 1)
-      in
-      Lprim(access, [transl_exp arg])
+      let targ = transl_exp arg in
+      begin match lbl.lbl_repres with
+          Record_regular | Record_inlined _ ->
+          Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc)
+        | Record_unboxed _ -> targ
+        | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc)
+        | Record_extension ->
+          Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc)
+      end
   | Texp_setfield(arg, _, lbl, newval) ->
       let access =
         match lbl.lbl_repres with
           Record_regular
         | Record_inlined _ ->
           Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)
+        | Record_unboxed _ -> assert false
         | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
         | Record_extension ->
           Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
       in
-      Lprim(access, [transl_exp arg; transl_exp newval])
+      Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc)
   | Texp_array expr_list ->
       let kind = array_kind e in
       let ll = transl_list expr_list in
@@ -885,8 +940,10 @@ and transl_exp0 e =
                where the array turned out to be inconstant).
                When not [Pfloatarray], the exception propagates to the handler
                below. *)
-            let imm_array = Lprim (Pmakearray (kind, Immutable), ll) in
-            Lprim (Pduparray (kind, Mutable), [imm_array])
+            let imm_array =
+              Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc)
+            in
+            Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc)
         | cl ->
             let imm_array =
               match kind with
@@ -897,10 +954,10 @@ and transl_exp0 e =
               | Pgenarray ->
                   raise Not_constant    (* can this really happen? *)
             in
-            Lprim (Pduparray (kind, Mutable), [imm_array])
+            Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc)
         end
       with Not_constant ->
-        Lprim(Pmakearray (kind, Mutable), ll)
+        Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc)
       end
   | Texp_ifthenelse(cond, ifso, Some ifnot) ->
       Lifthenelse(transl_exp cond,
@@ -932,18 +989,18 @@ and transl_exp0 e =
   | Texp_new (cl, {Location.loc=loc}, _) ->
       Lapply{ap_should_be_tailcall=false;
              ap_loc=loc;
-             ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]);
+             ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl], loc);
              ap_args=[lambda_unit];
              ap_inlined=Default_inline;
              ap_specialised=Default_specialise}
   | Texp_instvar(path_self, path, _) ->
       Lprim(Parrayrefu Paddrarray,
-            [transl_normal_path path_self; transl_normal_path path])
+            [transl_normal_path path_self; transl_normal_path path], e.exp_loc)
   | Texp_setinstvar(path_self, path, _, expr) ->
-      transl_setinstvar (transl_normal_path path_self) path expr
+      transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr
   | Texp_override(path_self, modifs) ->
       let cpy = Ident.create "copy" in
-      Llet(Strict, cpy,
+      Llet(Strict, Pgenval, cpy,
            Lapply{ap_should_be_tailcall=false;
                   ap_loc=Location.none;
                   ap_func=Translobj.oo_prim "copy";
@@ -952,11 +1009,18 @@ and transl_exp0 e =
                   ap_specialised=Default_specialise},
            List.fold_right
              (fun (path, _, expr) rem ->
-                Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
+                Lsequence(transl_setinstvar Location.none
+                            (Lvar cpy) path expr, rem))
              modifs
              (Lvar cpy))
   | Texp_letmodule(id, _, modl, body) ->
-      Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body)
+      Llet(Strict, Pgenval, id,
+           !transl_module Tcoerce_none None modl,
+           transl_exp body)
+  | Texp_letexception(cd, body) ->
+      Llet(Strict, Pgenval,
+           cd.ext_id, transl_extension_constructor e.exp_env None cd,
+           transl_exp body)
   | Texp_pack modl ->
       !transl_module Tcoerce_none None modl
   | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} ->
@@ -978,43 +1042,31 @@ and transl_exp0 e =
       | Texp_construct (_, {cstr_arity = 0}, _)
         -> transl_exp e
       | Texp_constant(Const_float _) ->
-          Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
-      | Texp_ident(_, _, _) -> (* according to the type *)
-          begin match e.exp_type.desc with
-          (* the following may represent a float/forward/lazy: need a
-             forward_tag *)
-          | Tvar _ | Tlink _ | Tsubst _ | Tunivar _
-          | Tpoly(_,_) | Tfield(_,_,_,_) ->
-              Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
-          (* the following cannot be represented as float/forward/lazy:
-             optimize *)
-          | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil
-          | Tvariant _
-              -> transl_exp e
-          (* optimize predefined types (excepted float) *)
-          | Tconstr(_,_,_) ->
-              if has_base_type e Predef.path_int
-                || has_base_type e Predef.path_char
-                || has_base_type e Predef.path_string
-                || has_base_type e Predef.path_bool
-                || has_base_type e Predef.path_unit
-                || has_base_type e Predef.path_exn
-                || has_base_type e Predef.path_array
-                || has_base_type e Predef.path_list
-                || has_base_type e Predef.path_option
-                || has_base_type e Predef.path_nativeint
-                || has_base_type e Predef.path_int32
-                || has_base_type e Predef.path_int64
-              then transl_exp e
-              else
-                Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
-          end
+          (* We don't need to wrap with Popaque: this forward
+             block will never be shortcutted since it points to a float. *)
+          Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
+                [transl_exp e], e.exp_loc)
+      | Texp_ident _ ->
+          (* CR-someday mshinwell: Consider adding a new primitive
+             that expresses the construction of forward_tag blocks.
+             We need to use [Popaque] here to prevent unsound
+             optimisation in Flambda, but the concept of a mutable
+             block doesn't really match what is going on here.  This
+             value may subsequently turn into an immediate... *)
+          if Typeopt.lazy_val_requires_forward e.exp_env e.exp_type
+          then
+            Lprim (Popaque,
+                   [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
+                          [transl_exp e], e.exp_loc)],
+                   e.exp_loc)
+          else transl_exp e
       (* other cases compile to a lazy block holding a function *)
       | _ ->
          let fn = Lfunction {kind = Curried; params = [Ident.create "param"];
                              attr = default_function_attribute;
+                             loc = e.exp_loc;
                              body = transl_exp e} in
-          Lprim(Pmakeblock(Config.lazy_tag, Mutable), [fn])
+          Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc)
       end
   | Texp_object (cs, meths) ->
       let cty = cs.cstr_type in
@@ -1032,6 +1084,13 @@ and transl_exp0 e =
 and transl_list expr_list =
   List.map transl_exp expr_list
 
+and transl_list_with_shape expr_list =
+  let transl_with_shape e =
+    let shape = Typeopt.value_kind e.exp_env e.exp_type in
+    transl_exp e, shape
+  in
+  List.split (List.map transl_with_shape expr_list)
+
 and transl_guard guard rhs =
   let expr = event_before rhs (transl_exp rhs) in
   match guard with
@@ -1109,17 +1168,19 @@ and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
         and id_arg = Ident.create "param" in
         let body =
           match build_apply handle ((Lvar id_arg, optional)::args') l with
-            Lfunction{kind = Curried; params = ids; body = lam; attr} ->
-              Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr}
+            Lfunction{kind = Curried; params = ids; body = lam; attr; loc} ->
+              Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr;
+                        loc}
           | Levent(Lfunction{kind = Curried; params = ids;
-                             body = lam; attr}, _) ->
-              Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr}
+                             body = lam; attr; loc}, _) ->
+              Lfunction{kind = Curried; params = id_arg::ids; body = lam; attr;
+                        loc}
           | lam ->
               Lfunction{kind = Curried; params = [id_arg]; body = lam;
-                        attr = default_function_attribute}
+                        attr = default_function_attribute; loc = loc}
         in
         List.fold_left
-          (fun body (id, lam) -> Llet(Strict, id, lam, body))
+          (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body))
           body !defs
     | (Some arg, optional) :: l ->
         build_apply lam ((arg, optional) :: args) l
@@ -1149,7 +1210,7 @@ and transl_function loc untuplify_fn repr partial cases =
             (fun {c_lhs; c_guard; c_rhs} ->
               (Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
             cases in
-        let params = List.map (fun p -> Ident.create "param") pl in
+        let params = List.map (fun _ -> Ident.create "param") pl in
         ((Tupled, params),
          Matching.for_tupled_function loc params
            (transl_tupled_cases pats_expr_list) partial)
@@ -1189,7 +1250,7 @@ and transl_let rec_flag pat_expr_list body =
             | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id
             | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
         pat_expr_list in
-      let transl_case {vb_pat=pat; vb_expr=expr; vb_attributes; vb_loc} id =
+      let transl_case {vb_expr=expr; vb_attributes; vb_loc} id =
         let lam = transl_exp expr in
         let lam =
           Translattribute.add_inline_attribute lam vb_loc
@@ -1204,42 +1265,45 @@ and transl_let rec_flag pat_expr_list body =
         (id, lam) in
       Lletrec(List.map2 transl_case pat_expr_list idlist, body)
 
-and transl_setinstvar self var expr =
+and transl_setinstvar loc self var expr =
   let prim =
     match maybe_pointer expr with
     | Pointer -> Paddrarray
     | Immediate -> Pintarray
   in
-  Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr])
-
-and transl_record env all_labels repres lbl_expr_list opt_init_expr =
-  let size = Array.length all_labels in
-  (* Determine if there are "enough" new fields *)
-  if 3 + 2 * List.length lbl_expr_list >= size
+  Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr], loc)
+
+and transl_record loc env fields repres opt_init_expr =
+  let size = Array.length fields in
+  (* Determine if there are "enough" fields (only relevant if this is a
+     functional-style record update *)
+  let no_init = match opt_init_expr with None -> true | _ -> false in
+  if no_init || size < Config.max_young_wosize
   then begin
     (* Allocate new record with given fields (and remaining fields
        taken from init_expr if any *)
-    let lv = Array.make (Array.length all_labels) staticfail in
     let init_id = Ident.create "init" in
-    begin match opt_init_expr with
-      None -> ()
-    | Some init_expr ->
-        for i = 0 to Array.length all_labels - 1 do
-          let access =
-            match all_labels.(i).lbl_repres with
-              Record_regular | Record_inlined _ -> Pfield i
-            | Record_extension -> Pfield (i + 1)
-            | Record_float -> Pfloatfield i in
-          lv.(i) <- Lprim(access, [Lvar init_id])
-        done
-    end;
-    List.iter
-      (fun (_, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr)
-      lbl_expr_list;
-    let ll = Array.to_list lv in
+    let lv =
+      Array.mapi
+        (fun i (_, definition) ->
+           match definition with
+           | Kept typ ->
+               let field_kind = value_kind env typ in
+               let access =
+                 match repres with
+                   Record_regular | Record_inlined _ -> Pfield i
+                 | Record_unboxed _ -> assert false
+                 | Record_extension -> Pfield (i + 1)
+                 | Record_float -> Pfloatfield i in
+               Lprim(access, [Lvar init_id], loc), field_kind
+           | Overridden (_lid, expr) ->
+               let field_kind = value_kind expr.exp_env expr.exp_type in
+               transl_exp expr, field_kind)
+        fields
+    in
+    let ll, shape = List.split (Array.to_list lv) in
     let mut =
-      if List.exists (fun lbl -> lbl.lbl_mut = Mutable)
-        (Array.to_list all_labels)
+      if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields
       then Mutable
       else Immutable in
     let lam =
@@ -1249,27 +1313,34 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
         match repres with
         | Record_regular -> Lconst(Const_block(0, cl))
         | Record_inlined tag -> Lconst(Const_block(tag, cl))
+        | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false)
         | Record_float ->
             Lconst(Const_float_array(List.map extract_float cl))
         | Record_extension ->
             raise Not_constant
       with Not_constant ->
         match repres with
-          Record_regular -> Lprim(Pmakeblock(0, mut), ll)
-        | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll)
-        | Record_float -> Lprim(Pmakearray (Pfloatarray, mut), ll)
+          Record_regular ->
+            Lprim(Pmakeblock(0, mut, Some shape), ll, loc)
+        | Record_inlined tag ->
+            Lprim(Pmakeblock(tag, mut, Some shape), ll, loc)
+        | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false)
+        | Record_float ->
+            Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
         | Record_extension ->
             let path =
-              match all_labels.(0).lbl_res.desc with
+              let (label, _) = fields.(0) in
+              match label.lbl_res.desc with
               | Tconstr(p, _, _) -> p
               | _ -> assert false
             in
             let slot = transl_path env path in
-            Lprim(Pmakeblock(0, mut), slot :: ll)
+            Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc)
     in
     begin match opt_init_expr with
       None -> lam
-    | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam)
+    | Some init_expr -> Llet(Strict, Pgenval, init_id,
+                             transl_exp init_expr, lam)
     end
   end else begin
     (* Take a shallow copy of the init record, then mutate the fields
@@ -1277,23 +1348,28 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
     (* If you change anything here, you will likely have to change
        [check_recursive_recordwith] in this file. *)
     let copy_id = Ident.create "newrecord" in
-    let update_field (_, lbl, expr) cont =
-      let upd =
-        match lbl.lbl_repres with
-          Record_regular
-        | Record_inlined _ ->
-          Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment)
-        | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
-        | Record_extension ->
-          Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
-      in
-      Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in
+    let update_field cont (lbl, definition) =
+      match definition with
+      | Kept _type -> cont
+      | Overridden (_lid, expr) ->
+          let upd =
+            match repres with
+              Record_regular
+            | Record_inlined _ ->
+                Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment)
+            | Record_unboxed _ -> assert false
+            | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
+            | Record_extension ->
+                Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
+          in
+          Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont)
+    in
     begin match opt_init_expr with
       None -> assert false
     | Some init_expr ->
-        Llet(Strict, copy_id,
-             Lprim(Pduprecord (repres, size), [transl_exp init_expr]),
-             List.fold_right update_field lbl_expr_list (Lvar copy_id))
+        Llet(Strict, Pgenval, copy_id,
+             Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc),
+             Array.fold_left update_field (Lvar copy_id) fields)
     end
   end
 

diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 16f2c8952654bbe1690f25d0abdce9261f6c9e1c..fb5a506083c1e56b82035b23c1a7018d49adfe07 100644 (file)
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -30,6 +30,9 @@ val transl_let: rec_flag -> value_binding list -> lambda -> lambda
 val transl_primitive: Location.t -> Primitive.description -> Env.t
                       -> Types.type_expr -> Path.t option -> lambda
 
+val transl_extension_constructor: Env.t -> Path.t option ->
+  extension_constructor -> lambda
+
 val check_recursive_lambda: Ident.t list -> lambda -> bool
 
 val used_primitives: (Path.t, Location.t) Hashtbl.t

diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 52b744c45d8d0341253ef3d0cf4b87de069fcd22..f2f6263ab4a5cc376879c8d5d7171c1bb7e8e9b9 100644 (file)
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -48,60 +48,44 @@ let field_path path field =
 
 (* Compile type extensions *)
 
-let prim_fresh_oo_id =
-  Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
-
-let transl_extension_constructor env path ext =
-  let name =
-    match path, !Clflags.for_package with
-      None, _ -> Ident.name ext.ext_id
-    | Some p, None -> Path.name p
-    | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
-  in
-  match ext.ext_kind with
-    Text_decl(args, ret) ->
-      Lprim (Pmakeblock (Obj.object_tag, Immutable),
-        [Lconst (Const_base (Const_string (name, None)));
-         Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))])])
-  | Text_rebind(path, lid) ->
-      transl_path ~loc:ext.ext_loc env path
-
 let transl_type_extension env rootpath tyext body =
   List.fold_right
     (fun ext body ->
       let lam =
         transl_extension_constructor env (field_path rootpath ext.ext_id) ext
       in
-      Llet(Strict, ext.ext_id, lam, body))
+      Llet(Strict, Pgenval, ext.ext_id, lam, body))
     tyext.tyext_constructors
     body
 
 (* Compile a coercion *)
 
-let rec apply_coercion strict restr arg =
+let rec apply_coercion loc strict restr arg =
   match restr with
     Tcoerce_none ->
       arg
   | Tcoerce_structure(pos_cc_list, id_pos_list) ->
       name_lambda strict arg (fun id ->
-        let get_field pos = Lprim(Pfield pos,[Lvar id]) in
+        let get_field pos = Lprim(Pfield pos,[Lvar id], loc) in
         let lam =
-          Lprim(Pmakeblock(0, Immutable),
-                List.map (apply_coercion_field get_field) pos_cc_list)
+          Lprim(Pmakeblock(0, Immutable, None),
+                List.map (apply_coercion_field loc get_field) pos_cc_list,
+                loc)
         in
-        wrap_id_pos_list id_pos_list get_field lam)
+        wrap_id_pos_list loc id_pos_list get_field lam)
   | Tcoerce_functor(cc_arg, cc_res) ->
       let param = Ident.create "funarg" in
       name_lambda strict arg (fun id ->
         Lfunction{kind = Curried; params = [param];
                   attr = { default_function_attribute with
                            is_a_functor = true };
+                  loc = loc;
                   body = apply_coercion
-                           Strict cc_res
+                           loc Strict cc_res
                            (Lapply{ap_should_be_tailcall=false;
-                                   ap_loc=Location.none;
+                                   ap_loc=loc;
                                    ap_func=Lvar id;
-                                   ap_args=[apply_coercion Alias cc_arg
+                                   ap_args=[apply_coercion loc Alias cc_arg
                                                            (Lvar param)];
                                    ap_inlined=Default_inline;
                                    ap_specialised=Default_specialise})})
@@ -109,12 +93,12 @@ let rec apply_coercion strict restr arg =
       transl_primitive pc_loc pc_desc pc_env pc_type None
   | Tcoerce_alias (path, cc) ->
       name_lambda strict arg
-        (fun id -> apply_coercion Alias cc (transl_normal_path path))
+        (fun _ -> apply_coercion loc Alias cc (transl_normal_path path))
 
-and apply_coercion_field get_field (pos, cc) =
-  apply_coercion Alias cc (get_field pos)
+and apply_coercion_field loc get_field (pos, cc) =
+  apply_coercion loc Alias cc (get_field pos)
 
-and wrap_id_pos_list id_pos_list get_field lam =
+and wrap_id_pos_list loc id_pos_list get_field lam =
   let fv = free_variables lam in
   (*Format.eprintf "%a@." Printlambda.lambda lam;
   IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
@@ -123,8 +107,8 @@ and wrap_id_pos_list id_pos_list get_field lam =
     List.fold_left (fun (lam,s) (id',pos,c) ->
       if IdentSet.mem id' fv then
         let id'' = Ident.create (Ident.name id') in
-        (Llet(Alias,id'',
-              apply_coercion Alias c (get_field pos),lam),
+        (Llet(Alias, Pgenval, id'',
+              apply_coercion loc Alias c (get_field pos),lam),
          Ident.add id' (Lvar id'') s)
       else (lam,s))
       (lam, Ident.empty) id_pos_list
@@ -210,7 +194,7 @@ let init_shape modl =
         Const_block (1, [Const_pointer 0])
     | Mty_signature sg ->
         Const_block(0, [Const_block(0, init_shape_struct env sg)])
-    | Mty_functor(id, arg, res) ->
+    | Mty_functor _ ->
         raise Not_found (* can we do better? *)
   and init_shape_struct env sg =
     match sg with
@@ -230,17 +214,18 @@ let init_shape modl =
         assert false
     | Sig_type(id, tdecl, _) :: rem ->
         init_shape_struct (Env.add_type ~check:false id tdecl env) rem
-    | Sig_typext(id, ext, _) :: rem ->
+    | Sig_typext _ :: _ ->
         raise Not_found
     | Sig_module(id, md, _) :: rem ->
         init_shape_mod env md.md_type ::
-        init_shape_struct (Env.add_module_declaration id md env) rem
+        init_shape_struct (Env.add_module_declaration ~check:false
+                             id md env) rem
     | Sig_modtype(id, minfo) :: rem ->
         init_shape_struct (Env.add_modtype id minfo env) rem
-    | Sig_class(id, cdecl, _) :: rem ->
+    | Sig_class _ :: rem ->
         Const_pointer 2 (* camlinternalMod.Class *)
         :: init_shape_struct env rem
-    | Sig_class_type(id, ctyp, _) :: rem ->
+    | Sig_class_type _ :: rem ->
         init_shape_struct env rem
   in
   try
@@ -289,10 +274,10 @@ let eval_rec_bindings bindings cont =
   let rec bind_inits = function
     [] ->
       bind_strict bindings
-  | (id, None, rhs) :: rem ->
+  | (_id, None, _rhs) :: rem ->
       bind_inits rem
-  | (id, Some(loc, shape), rhs) :: rem ->
-      Llet(Strict, id,
+  | (id, Some(loc, shape), _rhs) :: rem ->
+      Llet(Strict, Pgenval, id,
            Lapply{ap_should_be_tailcall=false;
                   ap_loc=Location.none;
                   ap_func=mod_prim "init_mod";
@@ -304,15 +289,15 @@ let eval_rec_bindings bindings cont =
     [] ->
       patch_forwards bindings
   | (id, None, rhs) :: rem ->
-      Llet(Strict, id, rhs, bind_strict rem)
-  | (id, Some(loc, shape), rhs) :: rem ->
+      Llet(Strict, Pgenval, id, rhs, bind_strict rem)
+  | (_id, Some _, _rhs) :: rem ->
       bind_strict rem
   and patch_forwards = function
     [] ->
       cont
-  | (id, None, rhs) :: rem ->
+  | (_id, None, _rhs) :: rem ->
       patch_forwards rem
-  | (id, Some(loc, shape), rhs) :: rem ->
+  | (id, Some(_loc, shape), rhs) :: rem ->
       Lsequence(Lapply{ap_should_be_tailcall=false;
                        ap_loc=Location.none;
                        ap_func=mod_prim "update_mod";
@@ -341,9 +326,9 @@ let rec bound_value_identifiers = function
     [] -> []
   | Sig_value(id, {val_kind = Val_reg}) :: rem ->
       id :: bound_value_identifiers rem
-  | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem
-  | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
-  | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
+  | Sig_typext(id, _, _) :: rem -> id :: bound_value_identifiers rem
+  | Sig_module(id, _, _) :: rem -> id :: bound_value_identifiers rem
+  | Sig_class(id, _, _) :: rem -> id :: bound_value_identifiers rem
   | _ :: rem -> bound_value_identifiers rem
 
 
@@ -362,16 +347,17 @@ let transl_class_bindings cl_list =
 let rec transl_module cc rootpath mexp =
   List.iter (Translattribute.check_attribute_on_module mexp)
     mexp.mod_attributes;
+  let loc = mexp.mod_loc in
   match mexp.mod_type with
-    Mty_alias _ -> apply_coercion Alias cc lambda_unit
+    Mty_alias _ -> apply_coercion loc Alias cc lambda_unit
   | _ ->
       match mexp.mod_desc with
         Tmod_ident (path,_) ->
-          apply_coercion Strict cc
-            (transl_path ~loc:mexp.mod_loc mexp.mod_env path)
+          apply_coercion loc Strict cc
+            (transl_path ~loc mexp.mod_env path)
       | Tmod_structure str ->
-          fst (transl_struct [] cc rootpath str)
-      | Tmod_functor( param, _, mty, body) ->
+          fst (transl_struct loc [] cc rootpath str)
+      | Tmod_functor(param, _, _, body) ->
           let bodypath = functor_path rootpath param in
           let inline_attribute =
             Translattribute.get_inline_attribute mexp.mod_attributes
@@ -383,6 +369,7 @@ let rec transl_module cc rootpath mexp =
                             attr = { inline = inline_attribute;
                                      specialise = Default_specialise;
                                      is_a_functor = true };
+                            loc = loc;
                             body = transl_module Tcoerce_none bodypath body}
               | Tcoerce_functor(ccarg, ccres) ->
                   let param' = Ident.create "funarg" in
@@ -390,8 +377,9 @@ let rec transl_module cc rootpath mexp =
                             attr = { inline = inline_attribute;
                                      specialise = Default_specialise;
                                      is_a_functor = true };
-                            body = Llet(Alias, param,
-                                        apply_coercion Alias ccarg
+                            loc = loc;
+                            body = Llet(Alias, Pgenval, param,
+                                        apply_coercion loc Alias ccarg
                                                        (Lvar param'),
                                         transl_module ccres bodypath body)}
               | _ ->
@@ -402,28 +390,28 @@ let rec transl_module cc rootpath mexp =
             Translattribute.get_and_remove_inlined_attribute_on_module funct
           in
           oo_wrap mexp.mod_env true
-            (apply_coercion Strict cc)
+            (apply_coercion loc Strict cc)
             (Lapply{ap_should_be_tailcall=false;
-                    ap_loc=mexp.mod_loc;
+                    ap_loc=loc;
                     ap_func=transl_module Tcoerce_none None funct;
                     ap_args=[transl_module ccarg None arg];
                     ap_inlined=inlined_attribute;
                     ap_specialised=Default_specialise})
-      | Tmod_constraint(arg, mty, _, ccarg) ->
+      | Tmod_constraint(arg, _, _, ccarg) ->
           transl_module (compose_coercions cc ccarg) rootpath arg
       | Tmod_unpack(arg, _) ->
-          apply_coercion Strict cc (Translcore.transl_exp arg)
+          apply_coercion loc Strict cc (Translcore.transl_exp arg)
 
-and transl_struct fields cc rootpath str =
-  transl_structure fields cc rootpath str.str_final_env str.str_items
+and transl_struct loc fields cc rootpath str =
+  transl_structure loc fields cc rootpath str.str_final_env str.str_items
 
-and transl_structure fields cc rootpath final_env = function
+and transl_structure loc fields cc rootpath final_env = function
     [] ->
       let body, size =
         match cc with
           Tcoerce_none ->
-            Lprim(Pmakeblock(0, Immutable),
-                  List.map (fun id -> Lvar id) (List.rev fields)),
+            Lprim(Pmakeblock(0, Immutable, None),
+                  List.map (fun id -> Lvar id) (List.rev fields), loc),
               List.length fields
         | Tcoerce_structure(pos_cc_list, id_pos_list) ->
                 (* Do not ignore id_pos_list ! *)
@@ -435,20 +423,20 @@ and transl_structure fields cc rootpath final_env = function
             let get_field pos = Lvar v.(pos)
             and ids = List.fold_right IdentSet.add fields IdentSet.empty in
             let lam =
-              (Lprim(Pmakeblock(0, Immutable),
+              Lprim(Pmakeblock(0, Immutable, None),
                   List.map
                     (fun (pos, cc) ->
                       match cc with
                         Tcoerce_primitive p ->
                           transl_primitive p.pc_loc
                             p.pc_desc p.pc_env p.pc_type None
-                      | _ -> apply_coercion Strict cc (get_field pos))
-                    pos_cc_list))
+                      | _ -> apply_coercion loc Strict cc (get_field pos))
+                    pos_cc_list, loc)
             and id_pos_list =
               List.filter (fun (id,_,_) -> not (IdentSet.mem id ids))
                 id_pos_list
             in
-            wrap_id_pos_list id_pos_list get_field lam,
+            wrap_id_pos_list loc id_pos_list get_field lam,
               List.length pos_cc_list
         | _ ->
             fatal_error "Translmod.transl_structure"
@@ -456,9 +444,9 @@ and transl_structure fields cc rootpath final_env = function
       (* This debugging event provides information regarding the structure
          items. It is ignored by the OCaml debugger but is used by
          Js_of_ocaml to preserve variable names. *)
-      (if !Clflags.debug then
+      (if !Clflags.debug && not !Clflags.native_code then
          Levent(body,
-                {lev_loc = Location.none;
+                {lev_loc = loc;
                  lev_kind = Lev_pseudo;
                  lev_repr = None;
                  lev_env = Env.summary final_env})
@@ -468,22 +456,25 @@ and transl_structure fields cc rootpath final_env = function
   | item :: rem ->
       match item.str_desc with
       | Tstr_eval (expr, _) ->
-          let body, size = transl_structure fields cc rootpath final_env rem in
+          let body, size =
+            transl_structure loc fields cc rootpath final_env rem
+          in
           Lsequence(transl_exp expr, body), size
       | Tstr_value(rec_flag, pat_expr_list) ->
           let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
           let body, size =
-            transl_structure ext_fields cc rootpath final_env rem in
+            transl_structure loc ext_fields cc rootpath final_env rem
+          in
           transl_let rec_flag pat_expr_list body, size
       | Tstr_primitive descr ->
           record_primitive descr.val_val;
-          transl_structure fields cc rootpath final_env rem
-      | Tstr_type(_, decls) ->
-          transl_structure fields cc rootpath final_env rem
+          transl_structure loc fields cc rootpath final_env rem
+      | Tstr_type _ ->
+          transl_structure loc fields cc rootpath final_env rem
       | Tstr_typext(tyext) ->
           let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
           let body, size =
-            transl_structure (List.rev_append ids fields)
+            transl_structure loc (List.rev_append ids fields)
               cc rootpath final_env rem
           in
           transl_type_extension item.str_env rootpath tyext body, size
@@ -491,13 +482,16 @@ and transl_structure fields cc rootpath final_env = function
           let id = ext.ext_id in
           let path = field_path rootpath id in
           let body, size =
-            transl_structure (id :: fields) cc rootpath final_env rem in
-          Llet(Strict, id, transl_extension_constructor item.str_env path ext,
-               body), size
+            transl_structure loc (id :: fields) cc rootpath final_env rem
+          in
+          Llet(Strict, Pgenval, id,
+               transl_extension_constructor item.str_env path ext, body),
+          size
       | Tstr_module mb ->
           let id = mb.mb_id in
           let body, size =
-            transl_structure (id :: fields) cc rootpath final_env rem in
+            transl_structure loc (id :: fields) cc rootpath final_env rem
+          in
           let module_body =
             transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
           in
@@ -505,7 +499,7 @@ and transl_structure fields cc rootpath final_env = function
             Translattribute.add_inline_attribute module_body mb.mb_loc
                                                  mb.mb_attributes
           in
-          Llet(pure_module mb.mb_expr, id,
+          Llet(pure_module mb.mb_expr, Pgenval, id,
                module_body,
                body), size
       | Tstr_recmodule bindings ->
@@ -513,7 +507,8 @@ and transl_structure fields cc rootpath final_env = function
             List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
           in
           let body, size =
-            transl_structure ext_fields cc rootpath final_env rem in
+            transl_structure loc ext_fields cc rootpath final_env rem
+          in
           let lam =
             compile_recmodule
               (fun id modl ->
@@ -525,7 +520,7 @@ and transl_structure fields cc rootpath final_env = function
       | Tstr_class cl_list ->
           let (ids, class_bindings) = transl_class_bindings cl_list in
           let body, size =
-            transl_structure (List.rev_append ids fields)
+            transl_structure loc (List.rev_append ids fields)
               cc rootpath final_env rem
           in
           Lletrec(class_bindings, body), size
@@ -535,22 +530,25 @@ and transl_structure fields cc rootpath final_env = function
           let mid = Ident.create "include" in
           let rec rebind_idents pos newfields = function
               [] ->
-                transl_structure newfields cc rootpath final_env rem
+                transl_structure loc newfields cc rootpath final_env rem
             | id :: ids ->
                 let body, size =
                   rebind_idents (pos + 1) (id :: newfields) ids
                 in
-                Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), body), size
+                Llet(Alias, Pgenval, id,
+                     Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body),
+                size
           in
           let body, size = rebind_idents 0 fields ids in
-          Llet(pure_module modl, mid, transl_module Tcoerce_none None modl,
-               body), size
+          Llet(pure_module modl, Pgenval, mid,
+               transl_module Tcoerce_none None modl, body),
+          size
 
       | Tstr_modtype _
       | Tstr_open _
       | Tstr_class_type _
       | Tstr_attribute _ ->
-          transl_structure fields cc rootpath final_env rem
+          transl_structure loc fields cc rootpath final_env rem
 
 and pure_module m =
   match m.mod_desc with
@@ -565,41 +563,35 @@ let _ =
 (* Introduce dependencies on modules referenced only by "external". *)
 
 let scan_used_globals lam =
-  let globals = ref IdentSet.empty in
+  let globals = ref Ident.Set.empty in
   let rec scan lam =
     Lambda.iter scan lam;
     match lam with
-      Lprim ((Pgetglobal id | Psetglobal id), _) ->
-        globals := IdentSet.add id !globals
+      Lprim ((Pgetglobal id | Psetglobal id), _, _) ->
+        globals := Ident.Set.add id !globals
     | _ -> ()
   in
   scan lam; !globals
 
-let wrap_globals ~flambda body =
+let required_globals ~flambda body =
   let globals = scan_used_globals body in
   let add_global id req =
-    if not flambda && IdentSet.mem id globals then
+    if not flambda && Ident.Set.mem id globals then
       req
     else
-      IdentSet.add id req
+      Ident.Set.add id req
   in
   let required =
     Hashtbl.fold
-      (fun path loc -> add_global (Path.head path)) used_primitives
-      (if flambda then globals else IdentSet.empty)
+      (fun path _ -> add_global (Path.head path)) used_primitives
+      (if flambda then globals else Ident.Set.empty)
   in
   let required =
     List.fold_right add_global (Env.get_required_globals ()) required
   in
   Env.reset_required_globals ();
   Hashtbl.clear used_primitives;
-  IdentSet.fold
-    (fun id expr -> Lsequence(Lprim(Popaque, [Lprim(Pgetglobal id, [])]), expr))
-    required body
-  (* Location.prerr_warning loc
-        (Warnings.Nonrequired_global (Ident.name (Path.head path),
-                                      "uses the primitive " ^
-                                      Printtyp.string_of_path path))) *)
+  required
 
 (* Compile an implementation *)
 
@@ -610,15 +602,23 @@ let transl_implementation_flambda module_name (str, cc) =
   let module_id = Ident.create_persistent module_name in
   let body, size =
     Translobj.transl_label_init
-      (fun () -> transl_struct [] cc (global_path module_id) str)
+      (fun () -> transl_struct Location.none [] cc
+                   (global_path module_id) str)
   in
-  (module_id, size), wrap_globals ~flambda:true body
+  { module_ident = module_id;
+    main_module_block_size = size;
+    required_globals = required_globals ~flambda:true body;
+    code = body }
 
 let transl_implementation module_name (str, cc) =
-  let (module_id, _size), module_initializer =
+  let implementation =
     transl_implementation_flambda module_name (str, cc)
   in
-  Lprim (Psetglobal module_id, [module_initializer])
+  let code =
+    Lprim (Psetglobal implementation.module_ident, [implementation.code],
+           Location.none)
+  in
+  { implementation with code }
 
 (* Build the list of value identifiers defined by a toplevel structure
    (excluding primitive declarations). *)
@@ -627,11 +627,11 @@ let rec defined_idents = function
     [] -> []
   | item :: rem ->
     match item.str_desc with
-    | Tstr_eval (expr, _) -> defined_idents rem
-    | Tstr_value(rec_flag, pat_expr_list) ->
+    | Tstr_eval _ -> defined_idents rem
+    | Tstr_value(_rec_flag, pat_expr_list) ->
       let_bound_idents pat_expr_list @ defined_idents rem
-    | Tstr_primitive desc -> defined_idents rem
-    | Tstr_type (_, decls) -> defined_idents rem
+    | Tstr_primitive _ -> defined_idents rem
+    | Tstr_type _ -> defined_idents rem
     | Tstr_typext tyext ->
       List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
       @ defined_idents rem
@@ -643,7 +643,7 @@ let rec defined_idents = function
     | Tstr_open _ -> defined_idents rem
     | Tstr_class cl_list ->
       List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem
-    | Tstr_class_type cl_list -> defined_idents rem
+    | Tstr_class_type _ -> defined_idents rem
     | Tstr_include incl ->
       bound_value_identifiers incl.incl_type @ defined_idents rem
     | Tstr_attribute _ -> defined_idents rem
@@ -654,17 +654,17 @@ let rec more_idents = function
     [] -> []
   | item :: rem ->
     match item.str_desc with
-    | Tstr_eval (expr, _attrs) -> more_idents rem
-    | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem
+    | Tstr_eval _ -> more_idents rem
+    | Tstr_value _ -> more_idents rem
     | Tstr_primitive _ -> more_idents rem
-    | Tstr_type (_, decls) -> more_idents rem
-    | Tstr_typext tyext -> more_idents rem
+    | Tstr_type _ -> more_idents rem
+    | Tstr_typext _ -> more_idents rem
     | Tstr_exception _ -> more_idents rem
-    | Tstr_recmodule decls -> more_idents rem
+    | Tstr_recmodule _ -> more_idents rem
     | Tstr_modtype _ -> more_idents rem
     | Tstr_open _ -> more_idents rem
-    | Tstr_class cl_list -> more_idents rem
-    | Tstr_class_type cl_list -> more_idents rem
+    | Tstr_class _ -> more_idents rem
+    | Tstr_class_type _ -> more_idents rem
     | Tstr_include _ -> more_idents rem
     | Tstr_module {mb_expr={mod_desc = Tmod_structure str}}
     | Tstr_module{mb_expr={mod_desc =
@@ -678,11 +678,11 @@ and all_idents = function
     [] -> []
   | item :: rem ->
     match item.str_desc with
-    | Tstr_eval (expr, _attrs) -> all_idents rem
-    | Tstr_value(rec_flag, pat_expr_list) ->
+    | Tstr_eval _ -> all_idents rem
+    | Tstr_value(_rec_flag, pat_expr_list) ->
       let_bound_idents pat_expr_list @ all_idents rem
     | Tstr_primitive _ -> all_idents rem
-    | Tstr_type (_, decls) -> all_idents rem
+    | Tstr_type _ -> all_idents rem
     | Tstr_typext tyext ->
       List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
       @ all_idents rem
@@ -693,7 +693,7 @@ and all_idents = function
     | Tstr_open _ -> all_idents rem
     | Tstr_class cl_list ->
       List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem
-    | Tstr_class_type cl_list -> all_idents rem
+    | Tstr_class_type _ -> all_idents rem
     | Tstr_include incl ->
       bound_value_identifiers incl.incl_type @ all_idents rem
     | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}}
@@ -721,7 +721,7 @@ let transl_store_subst = ref Ident.empty
 
 let nat_toplevel_name id =
   try match Ident.find_same id !transl_store_subst with
-    | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])]) -> (glob,pos)
+    | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos)
     | _ -> raise Not_found
   with Not_found ->
     fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)
@@ -738,13 +738,15 @@ let transl_store_structure glob map prims str =
                       transl_store rootpath subst rem)
         | Tstr_value(rec_flag, pat_expr_list) ->
             let ids = let_bound_idents pat_expr_list in
-            let lam = transl_let rec_flag pat_expr_list (store_idents ids) in
+            let lam =
+              transl_let rec_flag pat_expr_list (store_idents Location.none ids)
+            in
             Lsequence(subst_lambda subst lam,
                       transl_store rootpath (add_idents false ids subst) rem)
         | Tstr_primitive descr ->
             record_primitive descr.val_val;
             transl_store rootpath subst rem
-        | Tstr_type(_, decls) ->
+        | Tstr_type _ ->
             transl_store rootpath subst rem
         | Tstr_typext(tyext) ->
             let ids =
@@ -752,7 +754,7 @@ let transl_store_structure glob map prims str =
             in
             let lam =
               transl_type_extension item.str_env rootpath tyext
-                                    (store_idents ids)
+                                    (store_idents Location.none ids)
             in
             Lsequence(subst_lambda subst lam,
                       transl_store rootpath (add_idents false ids subst) rem)
@@ -760,9 +762,10 @@ let transl_store_structure glob map prims str =
             let id = ext.ext_id in
             let path = field_path rootpath id in
             let lam = transl_extension_constructor item.str_env path ext in
-            Lsequence(Llet(Strict, id, subst_lambda subst lam, store_ident id),
+            Lsequence(Llet(Strict, Pgenval, id, subst_lambda subst lam,
+                           store_ident ext.ext_loc id),
                       transl_store rootpath (add_ident false id subst) rem)
-        | Tstr_module{mb_id=id;
+        | Tstr_module{mb_id=id;mb_loc=loc;
                       mb_expr={mod_desc = Tmod_structure str} as mexp;
                       mb_attributes} ->
             List.iter (Translattribute.check_attribute_on_module mexp)
@@ -773,17 +776,17 @@ let transl_store_structure glob map prims str =
             (* Careful: see next case *)
             let subst = !transl_store_subst in
             Lsequence(lam,
-                      Llet(Strict, id,
+                      Llet(Strict, Pgenval, id,
                            subst_lambda subst
-                             (Lprim(Pmakeblock(0, Immutable),
+                             (Lprim(Pmakeblock(0, Immutable, None),
                                     List.map (fun id -> Lvar id)
-                                      (defined_idents str.str_items))),
-                           Lsequence(store_ident id,
+                                      (defined_idents str.str_items), loc)),
+                           Lsequence(store_ident loc id,
                                      transl_store rootpath
                                                   (add_ident true id subst)
                                                   rem)))
         | Tstr_module{
-            mb_id=id;
+            mb_id=id;mb_loc=loc;
             mb_expr= {
               mod_desc = Tmod_constraint (
                   {mod_desc = Tmod_structure str} as mexp, _, _,
@@ -804,22 +807,22 @@ let transl_store_structure glob map prims str =
               match cc with
               | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
                   transl_primitive pc_loc pc_desc pc_env pc_type None
-              | _ -> apply_coercion Strict cc (Lvar ids.(pos))
+              | _ -> apply_coercion loc Strict cc (Lvar ids.(pos))
             in
             Lsequence(lam,
-                      Llet(Strict, id,
+                      Llet(Strict, Pgenval, id,
                            subst_lambda subst
-                             (Lprim(Pmakeblock(0, Immutable),
-                                    List.map field map)),
-                           Lsequence(store_ident id,
+                             (Lprim(Pmakeblock(0, Immutable, None),
+                                    List.map field map, loc)),
+                           Lsequence(store_ident loc id,
                                      transl_store rootpath
                                                   (add_ident true id subst)
                                                   rem)))
-        | Tstr_module{mb_id=id; mb_expr=modl; mb_loc; mb_attributes} ->
+        | Tstr_module{mb_id=id; mb_expr=modl; mb_loc=loc; mb_attributes} ->
             let lam =
               Translattribute.add_inline_attribute
                 (transl_module Tcoerce_none (field_path rootpath id) modl)
-                mb_loc mb_attributes
+                loc mb_attributes
             in
             (* Careful: the module value stored in the global may be different
                from the local module value, in case a coercion is applied.
@@ -827,8 +830,8 @@ let transl_store_structure glob map prims str =
                the compilation unit (add_ident true returns subst unchanged).
                If not, we can use the value from the global
                (add_ident true adds id -> Pgetglobal... to subst). *)
-            Llet(Strict, id, subst_lambda subst lam,
-                 Lsequence(store_ident id,
+            Llet(Strict, Pgenval, id, subst_lambda subst lam,
+                 Lsequence(store_ident loc id,
                            transl_store rootpath (add_ident true id subst) rem))
         | Tstr_recmodule bindings ->
             let ids = List.map (fun mb -> mb.mb_id) bindings in
@@ -838,23 +841,28 @@ let transl_store_structure glob map prims str =
                    (transl_module Tcoerce_none
                       (field_path rootpath id) modl))
               bindings
-              (Lsequence(store_idents ids,
+              (Lsequence(store_idents Location.none ids,
                          transl_store rootpath (add_idents true ids subst) rem))
         | Tstr_class cl_list ->
             let (ids, class_bindings) = transl_class_bindings cl_list in
-            let lam = Lletrec(class_bindings, store_idents ids) in
+            let lam =
+              Lletrec(class_bindings, store_idents Location.none ids)
+            in
             Lsequence(subst_lambda subst lam,
                       transl_store rootpath (add_idents false ids subst) rem)
         | Tstr_include incl ->
             let ids = bound_value_identifiers incl.incl_type in
             let modl = incl.incl_mod in
             let mid = Ident.create "include" in
+            let loc = incl.incl_loc in
             let rec store_idents pos = function
                 [] -> transl_store rootpath (add_idents true ids subst) rem
               | id :: idl ->
-                  Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]),
-                       Lsequence(store_ident id, store_idents (pos + 1) idl)) in
-            Llet(Strict, mid,
+                  Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc),
+                       Lsequence(store_ident loc id,
+                                 store_idents (pos + 1) idl))
+            in
+            Llet(Strict, Pgenval, mid,
                  subst_lambda subst (transl_module Tcoerce_none None modl),
                  store_idents 0 ids)
         | Tstr_modtype _
@@ -863,24 +871,29 @@ let transl_store_structure glob map prims str =
         | Tstr_attribute _ ->
             transl_store rootpath subst rem
 
-  and store_ident id =
+  and store_ident loc id =
     try
       let (pos, cc) = Ident.find_same id map in
-      let init_val = apply_coercion Alias cc (Lvar id) in
+      let init_val = apply_coercion loc Alias cc (Lvar id) in
       Lprim(Psetfield(pos, Pointer, Initialization),
-        [Lprim(Pgetglobal glob, []); init_val])
+            [Lprim(Pgetglobal glob, [], loc); init_val],
+            loc)
     with Not_found ->
       fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
 
-  and store_idents idlist =
-    make_sequence store_ident idlist
+  and store_idents loc idlist =
+    make_sequence (store_ident loc) idlist
 
   and add_ident may_coerce id subst =
     try
       let (pos, cc) = Ident.find_same id map in
       match cc with
         Tcoerce_none ->
-          Ident.add id (Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])])) subst
+          Ident.add id
+            (Lprim(Pfield pos,
+                   [Lprim(Pgetglobal glob, [], Location.none)],
+                   Location.none))
+            subst
       | _ ->
           if may_coerce then subst else assert false
     with Not_found ->
@@ -891,9 +904,10 @@ let transl_store_structure glob map prims str =
 
   and store_primitive (pos, prim) cont =
     Lsequence(Lprim(Psetfield(pos, Pointer, Initialization),
-                    [Lprim(Pgetglobal glob, []);
+                    [Lprim(Pgetglobal glob, [], Location.none);
                      transl_primitive Location.none
-                       prim.pc_desc prim.pc_env prim.pc_type None]),
+                       prim.pc_desc prim.pc_env prim.pc_type None],
+                    Location.none),
               cont)
 
   in List.fold_right store_primitive prims
@@ -927,7 +941,7 @@ let build_ident_map restr idlist more_ids =
         let rec export_map pos map prims undef = function
         [] ->
           natural_map pos map prims undef
-          | (source_pos, Tcoerce_primitive p) :: rem ->
+          | (_source_pos, Tcoerce_primitive p) :: rem ->
             export_map (pos + 1) map ((pos, p) :: prims) undef rem
           | (source_pos, cc) :: rem ->
             let id = idarray.(source_pos) in
@@ -963,10 +977,14 @@ let transl_store_phrases module_name str =
 let transl_store_implementation module_name (str, restr) =
   let s = !transl_store_subst in
   transl_store_subst := Ident.empty;
-  let (i, r) = transl_store_gen module_name (str, restr) false in
+  let (i, code) = transl_store_gen module_name (str, restr) false in
   transl_store_subst := s;
   { Lambda.main_module_block_size = i;
-    code = wrap_globals ~flambda:false r; }
+    code;
+    (* module_ident is not used by closure, but this allow to share
+       the type with the flambda version *)
+    module_ident = Ident.create_persistent module_name;
+    required_globals = required_globals ~flambda:true code }
 
 (* Compile a toplevel phrase *)
 
@@ -988,7 +1006,8 @@ let toploop_getvalue id =
   Lapply{ap_should_be_tailcall=false;
          ap_loc=Location.none;
          ap_func=Lprim(Pfield toploop_getvalue_pos,
-                       [Lprim(Pgetglobal toploop_ident, [])]);
+                       [Lprim(Pgetglobal toploop_ident, [], Location.none)],
+                       Location.none);
          ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))];
          ap_inlined=Default_inline;
          ap_specialised=Default_specialise}
@@ -997,7 +1016,8 @@ let toploop_setvalue id lam =
   Lapply{ap_should_be_tailcall=false;
          ap_loc=Location.none;
          ap_func=Lprim(Pfield toploop_setvalue_pos,
-                       [Lprim(Pgetglobal toploop_ident, [])]);
+                       [Lprim(Pgetglobal toploop_ident, [], Location.none)],
+                       Location.none);
          ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)));
                   lam];
          ap_inlined=Default_inline;
@@ -1006,7 +1026,8 @@ let toploop_setvalue id lam =
 let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
 
 let close_toplevel_term (lam, ()) =
-  IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l))
+  IdentSet.fold (fun id l -> Llet(Strict, Pgenval, id,
+                                  toploop_getvalue id, l))
                 (free_variables lam) lam
 
 let transl_toplevel_item item =
@@ -1062,9 +1083,11 @@ let transl_toplevel_item item =
         [] ->
           lambda_unit
       | id :: ids ->
-          Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])),
+          Lsequence(toploop_setvalue id
+                      (Lprim(Pfield pos, [Lvar mid], Location.none)),
                     set_idents (pos + 1) ids) in
-      Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids)
+      Llet(Strict, Pgenval, mid,
+           transl_module Tcoerce_none None modl, set_idents 0 ids)
   | Tstr_modtype _
   | Tstr_open _
   | Tstr_primitive _
@@ -1086,9 +1109,9 @@ let transl_toplevel_definition str =
 
 let get_component = function
     None -> Lconst const_unit
-  | Some id -> Lprim(Pgetglobal id, [])
+  | Some id -> Lprim(Pgetglobal id, [], Location.none)
 
-let transl_package_flambda component_names target_name coercion =
+let transl_package_flambda component_names coercion =
   let size =
     match coercion with
     | Tcoerce_none -> List.length component_names
@@ -1098,13 +1121,18 @@ let transl_package_flambda component_names target_name coercion =
     | Tcoerce_alias _ -> assert false
   in
   size,
-  apply_coercion Strict coercion
-    (Lprim(Pmakeblock(0, Immutable), List.map get_component component_names))
+  apply_coercion Location.none Strict coercion
+    (Lprim(Pmakeblock(0, Immutable, None),
+           List.map get_component component_names,
+           Location.none))
 
 let transl_package component_names target_name coercion =
   let components =
-    Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in
-  Lprim(Psetglobal target_name, [apply_coercion Strict coercion components])
+    Lprim(Pmakeblock(0, Immutable, None),
+          List.map get_component component_names, Location.none) in
+  Lprim(Psetglobal target_name,
+        [apply_coercion Location.none Strict coercion components],
+        Location.none)
   (*
   let components =
     match coercion with
@@ -1132,21 +1160,26 @@ let transl_store_package component_names target_name coercion =
        make_sequence
          (fun pos id ->
            Lprim(Psetfield(pos, Pointer, Initialization),
-                 [Lprim(Pgetglobal target_name, []);
-                  get_component id]))
+                 [Lprim(Pgetglobal target_name, [], Location.none);
+                  get_component id],
+                 Location.none))
          0 component_names)
-  | Tcoerce_structure (pos_cc_list, id_pos_list) ->
+  | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
       let components =
-        Lprim(Pmakeblock(0, Immutable), List.map get_component component_names)
+        Lprim(Pmakeblock(0, Immutable, None),
+              List.map get_component component_names,
+              Location.none)
       in
       let blk = Ident.create "block" in
       (List.length pos_cc_list,
-       Llet (Strict, blk, apply_coercion Strict coercion components,
+       Llet (Strict, Pgenval, blk,
+             apply_coercion Location.none Strict coercion components,
              make_sequence
-               (fun pos id ->
+               (fun pos _id ->
                  Lprim(Psetfield(pos, Pointer, Initialization),
-                       [Lprim(Pgetglobal target_name, []);
-                        Lprim(Pfield pos, [Lvar blk])]))
+                       [Lprim(Pgetglobal target_name, [], Location.none);
+                        Lprim(Pfield pos, [Lvar blk], Location.none)],
+                       Location.none))
                0 pos_cc_list))
   (*
               (* ignore id_pos_list as the ids are already bound *)

diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index 3628a9981bd23d8f92452ccdf56c32f74048f44b..f613a2f421a018f882de2e3ce03a5be269c956bf 100644 (file)
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -19,13 +19,14 @@
 open Typedtree
 open Lambda
 
-val transl_implementation: string -> structure * module_coercion -> lambda
+val transl_implementation:
+      string -> structure * module_coercion -> Lambda.program
 val transl_store_phrases: string -> structure -> int * lambda
 val transl_store_implementation:
       string -> structure * module_coercion -> Lambda.program
 
 val transl_implementation_flambda:
-  string -> structure * module_coercion -> (Ident.t * int) * lambda
+  string -> structure * module_coercion -> Lambda.program
 
 val transl_toplevel_definition: structure -> lambda
 val transl_package:
@@ -34,7 +35,7 @@ val transl_store_package:
       Ident.t option list -> Ident.t -> module_coercion -> int * lambda
 
 val transl_package_flambda:
-      Ident.t option list -> Ident.t -> module_coercion -> int * lambda
+      Ident.t option list -> module_coercion -> int * lambda
 
 val toplevel_name: Ident.t -> string
 val nat_toplevel_name: Ident.t -> Ident.t * int

diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 1e860502aed80ccdc86ffd36859b24d97df989a2..67f469c0cf1dea1fdc1ac928ae8ea1beb6ed7582 100644 (file)
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -33,7 +33,7 @@ let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17
 
 let share c =
   match c with
-    Const_block (n, l) when l <> [] ->
+    Const_block (_n, l) when l <> [] ->
       begin try
         Lvar (Hashtbl.find consts c)
       with Not_found ->
@@ -58,9 +58,9 @@ let next_cache tag =
   (tag, [!method_cache; Lconst(Const_base(Const_int n))])
 
 let rec is_path = function
-    Lvar _ | Lprim (Pgetglobal _, []) | Lconst _ -> true
-  | Lprim (Pfield _, [lam]) -> is_path lam
-  | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2]) ->
+    Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true
+  | Lprim (Pfield _, [lam], _) -> is_path lam
+  | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) ->
       is_path lam1 && is_path lam2
   | _ -> false
 
@@ -98,12 +98,12 @@ let transl_label_init_general f =
   let expr, size = f () in
   let expr =
     Hashtbl.fold
-      (fun c id expr -> Llet(Alias, id, Lconst c, expr))
+      (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr))
       consts expr
   in
   (*let expr =
     List.fold_right
-      (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
+      (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr))
       (Env.get_required_globals ()) expr
   in
   Env.reset_required_globals ();*)
@@ -121,8 +121,10 @@ let transl_label_init_flambda f =
   let expr =
     if !method_count = 0 then expr
     else
-      Llet (Strict, method_cache_id,
-        Lprim (Pccall prim_makearray, [int !method_count; int 0]),
+      Llet (Strict, Pgenval, method_cache_id,
+        Lprim (Pccall prim_makearray,
+               [int !method_count; int 0],
+               Location.none),
         expr)
   in
   transl_label_init_general (fun () -> expr, size)
@@ -130,15 +132,20 @@ let transl_label_init_flambda f =
 let transl_store_label_init glob size f arg =
   assert(not Config.flambda);
   assert(!Clflags.native_code);
-  method_cache := Lprim(Pfield size, [Lprim(Pgetglobal glob, [])]);
+  method_cache := Lprim(Pfield size,
+                        [Lprim(Pgetglobal glob, [], Location.none)],
+                        Location.none);
   let expr = f arg in
   let (size, expr) =
     if !method_count = 0 then (size, expr) else
     (size+1,
      Lsequence(
      Lprim(Psetfield(size, Pointer, Initialization),
-           [Lprim(Pgetglobal glob, []);
-            Lprim (Pccall prim_makearray, [int !method_count; int 0])]),
+           [Lprim(Pgetglobal glob, [], Location.none);
+            Lprim (Pccall prim_makearray,
+                   [int !method_count; int 0],
+                   Location.none)],
+           Location.none),
      expr))
   in
   let lam, size = transl_label_init_general (fun () -> (expr, size)) in
@@ -176,9 +183,10 @@ let oo_wrap env req f x =
     let lambda =
       List.fold_left
         (fun lambda id ->
-          Llet(StrictOpt, id,
-               Lprim(Pmakeblock(0, Mutable),
-                     [lambda_unit; lambda_unit; lambda_unit]),
+          Llet(StrictOpt, Pgenval, id,
+               Lprim(Pmakeblock(0, Mutable, None),
+                     [lambda_unit; lambda_unit; lambda_unit],
+                     Location.none),
                lambda))
         lambda !classes
     in

diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index 60aff406f1dd7e8d62cb0da596cbd3a0a4852c3b..93b7ec65592b8d1996c31b5b0c06d20dbf9da6d2 100644 (file)
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -20,8 +20,23 @@ open Types
 open Typedtree
 open Lambda
 
+let scrape_ty env ty =
+  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
+  match ty.desc with
+  | Tconstr (p, _, _) ->
+      begin match Env.find_type p env with
+      | {type_unboxed = {unboxed = true; _}; _} ->
+        begin match Typedecl.get_unboxed_type_representation env ty with
+        | None -> ty
+        | Some ty2 -> ty2
+        end
+      | _ -> ty
+      | exception Not_found -> ty
+      end
+  | _ -> ty
+
 let scrape env ty =
-  (Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc
+  (scrape_ty env ty).desc
 
 let is_function_type env ty =
   match scrape env ty with
@@ -33,9 +48,6 @@ let is_base_type env ty base_ty_path =
   | Tconstr(p, _, _) -> Path.same p base_ty_path
   | _ -> false
 
-let has_base_type exp base_ty_path =
-  is_base_type exp.exp_env exp.exp_type base_ty_path
-
 let maybe_pointer_type env ty =
   if Ctype.maybe_pointer_type env ty then
     Pointer
@@ -44,46 +56,57 @@ let maybe_pointer_type env ty =
 
 let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
 
-let array_element_kind env ty =
-  match scrape env ty with
+type classification =
+  | Int
+  | Float
+  | Lazy
+  | Addr  (* anything except a float or a lazy *)
+  | Any
+
+let classify env ty =
+  let ty = scrape_ty env ty in
+  if maybe_pointer_type env ty = Immediate then Int
+  else match ty.desc with
   | Tvar _ | Tunivar _ ->
-      Pgenarray
-  | Tconstr(p, args, abbrev) ->
-      if Path.same p Predef.path_int || Path.same p Predef.path_char then
-        Pintarray
-      else if Path.same p Predef.path_float then
-        Pfloatarray
+      Any
+  | Tconstr (p, _args, _abbrev) ->
+      if Path.same p Predef.path_float then Float
+      else if Path.same p Predef.path_lazy_t then Lazy
       else if Path.same p Predef.path_string
+           || Path.same p Predef.path_bytes
            || Path.same p Predef.path_array
            || Path.same p Predef.path_nativeint
            || Path.same p Predef.path_int32
-           || Path.same p Predef.path_int64 then
-        Paddrarray
+           || Path.same p Predef.path_int64 then Addr
       else begin
         try
-          match Env.find_type p env with
-            {type_kind = Type_abstract} ->
-              Pgenarray
-          | {type_kind = Type_variant cstrs}
-            when List.for_all (fun c -> c.Types.cd_args = Types.Cstr_tuple [])
-                cstrs ->
-              Pintarray
-          | {type_kind = _} ->
-              Paddrarray
+          match (Env.find_type p env).type_kind with
+          | Type_abstract ->
+              Any
+          | Type_record _ | Type_variant _ | Type_open ->
+              Addr
         with Not_found ->
           (* This can happen due to e.g. missing -I options,
              causing some .cmi files to be unavailable.
              Maybe we should emit a warning. *)
-          Pgenarray
+          Any
       end
-  | _ ->
-      Paddrarray
+  | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ ->
+      Addr
+  | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ ->
+      assert false
 
 let array_type_kind env ty =
   match scrape env ty with
   | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _)
     when Path.same p Predef.path_array ->
-      array_element_kind env elt_ty
+      begin match classify env elt_ty with
+      | Any -> Pgenarray
+      | Float -> Pfloatarray
+      | Addr | Lazy -> Paddrarray
+      | Int -> Pintarray
+      end
+
   | _ ->
       (* This can happen with e.g. Obj.field *)
       Pgenarray
@@ -120,9 +143,32 @@ let layout_table =
 
 let bigarray_type_kind_and_layout env typ =
   match scrape env typ with
-  | Tconstr(p, [caml_type; elt_type; layout_type], abbrev) ->
+  | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) ->
       (bigarray_decode_type env elt_type kind_table Pbigarray_unknown,
        bigarray_decode_type env layout_type layout_table
                             Pbigarray_unknown_layout)
   | _ ->
       (Pbigarray_unknown, Pbigarray_unknown_layout)
+
+let value_kind env ty =
+  match scrape env ty with
+  | Tconstr(p, _, _) when Path.same p Predef.path_int ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_char ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_float ->
+      Pfloatval
+  | Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
+      Pboxedintval Pint32
+  | Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
+      Pboxedintval Pint64
+  | Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
+      Pboxedintval Pnativeint
+  | _ ->
+      Pgenval
+
+
+let lazy_val_requires_forward env ty =
+  match classify env ty with
+  | Any | Float | Lazy -> true
+  | Addr | Int -> false

diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli
index d69f09eb86ad2f567f225474bd42e0b4ecab2863..6ac3bbcc85aa14cc521c4b6f6b57ff410e9ce99f 100644 (file)
--- a/bytecomp/typeopt.mli
+++ b/bytecomp/typeopt.mli
@@ -18,7 +18,6 @@
 val is_function_type :
       Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option
 val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool
-val has_base_type : Typedtree.expression -> Path.t -> bool
 
 val maybe_pointer_type : Env.t -> Types.type_expr
   -> Lambda.immediate_or_pointer
@@ -29,3 +28,8 @@ val array_kind : Typedtree.expression -> Lambda.array_kind
 val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
 val bigarray_type_kind_and_layout :
       Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
+val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+
+val lazy_val_requires_forward : Env.t -> Types.type_expr -> bool
+  (** Whether a forward block is needed for a lazy thunk on a value, i.e.
+      if the value can be represented as a float/forward/lazy *)

diff --git a/byterun/.depend b/byterun/.depend
index c1a4243c608523df0ede8ebcb0f926116e1d6926..c3f82b66db6151d171d4990529282bbc9458ed83 100644 (file)
--- a/byterun/.depend
+++ b/byterun/.depend
@@ -6,7 +6,8 @@ alloc.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \
 array.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \
-  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \
+  spacetime.h
 backtrace.o: backtrace.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
@@ -28,7 +29,7 @@ compact.o: compact.c caml/address_class.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/compatibility.h \
   caml/misc.h caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h \
   caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
-  caml/gc_ctrl.h caml/weak.h
+  caml/gc_ctrl.h caml/weak.h caml/compact.h
 compare.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
   caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@@ -60,9 +61,9 @@ fail.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/printexc.h caml/signals.h caml/stacks.h
 finalise.o: finalise.c caml/callback.h caml/compatibility.h \
   caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/fail.h caml/roots.h \
-  caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
-  caml/minor_gc.h caml/address_class.h caml/signals.h
+  caml/../../config/s.h caml/misc.h caml/compact.h caml/fail.h \
+  caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
 fix_code.o: fix_code.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \
   caml/mlvalues.h caml/fix_code.h caml/instruct.h caml/intext.h \
@@ -123,8 +124,8 @@ lexing.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \
 main.o: main.c caml/misc.h caml/compatibility.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/sys.h
 major_gc.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \
-  caml/mlvalues.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
+  caml/../../config/s.h caml/compatibility.h caml/misc.h caml/mlvalues.h \
+  caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
   caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
   caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/weak.h
 md5.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
@@ -155,7 +156,8 @@ misc.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
 obj.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
   caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h \
-  caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h
+  caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h \
+  spacetime.h
 parsing.o: parsing.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \
   caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@@ -181,6 +183,9 @@ signals_byt.o: signals_byt.c caml/config.h caml/../../config/m.h \
   caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
   caml/signals_machdep.h
+spacetime.o: spacetime.c caml/fail.h caml/compatibility.h caml/misc.h \
+  caml/config.h caml/../../config/m.h caml/../../config/s.h \
+  caml/mlvalues.h
 stacks.o: stacks.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \
   caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \
@@ -208,7 +213,7 @@ sys.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/instruct.h caml/io.h \
   caml/osdeps.h caml/signals.h caml/stacks.h caml/memory.h caml/gc.h \
   caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
-  caml/sys.h
+  caml/sys.h caml/version.h
 terminfo.o: terminfo.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \
   caml/mlvalues.h caml/fail.h caml/io.h
@@ -216,7 +221,7 @@ unix.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/compatibility.h caml/fail.h caml/misc.h caml/mlvalues.h \
   caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
-  caml/sys.h
+  caml/sys.h caml/io.h
 weak.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \
@@ -230,7 +235,8 @@ alloc.d.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \
 array.d.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \
-  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \
+  spacetime.h
 backtrace.d.o: backtrace.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
@@ -252,7 +258,7 @@ compact.d.o: compact.c caml/address_class.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/compatibility.h \
   caml/misc.h caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h \
   caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
-  caml/gc_ctrl.h caml/weak.h
+  caml/gc_ctrl.h caml/weak.h caml/compact.h
 compare.d.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
   caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@@ -284,9 +290,9 @@ fail.d.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/printexc.h caml/signals.h caml/stacks.h
 finalise.d.o: finalise.c caml/callback.h caml/compatibility.h \
   caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/fail.h caml/roots.h \
-  caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
-  caml/minor_gc.h caml/address_class.h caml/signals.h
+  caml/../../config/s.h caml/misc.h caml/compact.h caml/fail.h \
+  caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
 fix_code.d.o: fix_code.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \
   caml/mlvalues.h caml/fix_code.h caml/instruct.h caml/intext.h \
@@ -351,8 +357,8 @@ lexing.d.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \
 main.d.o: main.c caml/misc.h caml/compatibility.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/sys.h
 major_gc.d.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \
-  caml/mlvalues.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
+  caml/../../config/s.h caml/compatibility.h caml/misc.h caml/mlvalues.h \
+  caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
   caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
   caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/weak.h
 md5.d.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
@@ -383,7 +389,8 @@ misc.d.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
 obj.d.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
   caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h \
-  caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h
+  caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h \
+  spacetime.h
 parsing.d.o: parsing.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \
   caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@@ -409,6 +416,9 @@ signals_byt.d.o: signals_byt.c caml/config.h caml/../../config/m.h \
   caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
   caml/signals_machdep.h
+spacetime.d.o: spacetime.c caml/fail.h caml/compatibility.h caml/misc.h \
+  caml/config.h caml/../../config/m.h caml/../../config/s.h \
+  caml/mlvalues.h
 stacks.d.o: stacks.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \
   caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \
@@ -436,7 +446,7 @@ sys.d.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/instruct.h caml/io.h \
   caml/osdeps.h caml/signals.h caml/stacks.h caml/memory.h caml/gc.h \
   caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
-  caml/sys.h
+  caml/sys.h caml/version.h
 terminfo.d.o: terminfo.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \
   caml/mlvalues.h caml/fail.h caml/io.h
@@ -444,7 +454,7 @@ unix.d.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/compatibility.h caml/fail.h caml/misc.h caml/mlvalues.h \
   caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
-  caml/sys.h
+  caml/sys.h caml/io.h
 weak.d.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \
@@ -458,7 +468,8 @@ alloc.i.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \
 array.i.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \
-  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \
+  spacetime.h
 backtrace.i.o: backtrace.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
@@ -480,7 +491,7 @@ compact.i.o: compact.c caml/address_class.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/compatibility.h \
   caml/misc.h caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h \
   caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
-  caml/gc_ctrl.h caml/weak.h
+  caml/gc_ctrl.h caml/weak.h caml/compact.h
 compare.i.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
   caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@@ -512,9 +523,9 @@ fail.i.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/printexc.h caml/signals.h caml/stacks.h
 finalise.i.o: finalise.c caml/callback.h caml/compatibility.h \
   caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/fail.h caml/roots.h \
-  caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
-  caml/minor_gc.h caml/address_class.h caml/signals.h
+  caml/../../config/s.h caml/misc.h caml/compact.h caml/fail.h \
+  caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
 fix_code.i.o: fix_code.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \
   caml/mlvalues.h caml/fix_code.h caml/instruct.h caml/intext.h \
@@ -575,8 +586,8 @@ lexing.i.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \
 main.i.o: main.c caml/misc.h caml/compatibility.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/sys.h
 major_gc.i.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \
-  caml/mlvalues.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
+  caml/../../config/s.h caml/compatibility.h caml/misc.h caml/mlvalues.h \
+  caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
   caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
   caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/weak.h
 md5.i.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
@@ -607,7 +618,8 @@ misc.i.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
 obj.i.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
   caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h \
-  caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h
+  caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h \
+  spacetime.h
 parsing.i.o: parsing.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \
   caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@@ -633,6 +645,9 @@ signals_byt.i.o: signals_byt.c caml/config.h caml/../../config/m.h \
   caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
   caml/signals_machdep.h
+spacetime.i.o: spacetime.c caml/fail.h caml/compatibility.h caml/misc.h \
+  caml/config.h caml/../../config/m.h caml/../../config/s.h \
+  caml/mlvalues.h
 stacks.i.o: stacks.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \
   caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \
@@ -660,7 +675,7 @@ sys.i.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/instruct.h caml/io.h \
   caml/osdeps.h caml/signals.h caml/stacks.h caml/memory.h caml/gc.h \
   caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
-  caml/sys.h
+  caml/sys.h caml/version.h
 terminfo.i.o: terminfo.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \
   caml/mlvalues.h caml/fail.h caml/io.h
@@ -668,7 +683,7 @@ unix.i.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/compatibility.h caml/fail.h caml/misc.h caml/mlvalues.h \
   caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
-  caml/sys.h
+  caml/sys.h caml/io.h
 weak.i.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \
@@ -682,7 +697,8 @@ alloc.pic.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \
 array.pic.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \
-  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h \
+  spacetime.h
 backtrace.pic.o: backtrace.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \
@@ -704,7 +720,7 @@ compact.pic.o: compact.c caml/address_class.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/compatibility.h \
   caml/misc.h caml/mlvalues.h caml/finalise.h caml/roots.h caml/memory.h \
   caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
-  caml/gc_ctrl.h caml/weak.h
+  caml/gc_ctrl.h caml/weak.h caml/compact.h
 compare.pic.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
   caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@@ -736,9 +752,9 @@ fail.pic.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/printexc.h caml/signals.h caml/stacks.h
 finalise.pic.o: finalise.c caml/callback.h caml/compatibility.h \
   caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/fail.h caml/roots.h \
-  caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
-  caml/minor_gc.h caml/address_class.h caml/signals.h
+  caml/../../config/s.h caml/misc.h caml/compact.h caml/fail.h \
+  caml/finalise.h caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
 fix_code.pic.o: fix_code.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \
   caml/mlvalues.h caml/fix_code.h caml/instruct.h caml/intext.h \
@@ -799,8 +815,8 @@ lexing.pic.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \
 main.pic.o: main.c caml/misc.h caml/compatibility.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/sys.h
 major_gc.pic.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \
-  caml/mlvalues.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
+  caml/../../config/s.h caml/compatibility.h caml/misc.h caml/mlvalues.h \
+  caml/custom.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
   caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
   caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/weak.h
 md5.pic.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
@@ -831,7 +847,8 @@ misc.pic.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
 obj.pic.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \
   caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
   caml/fail.h caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h \
-  caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h
+  caml/memory.h caml/minor_gc.h caml/address_class.h caml/prims.h \
+  spacetime.h
 parsing.pic.o: parsing.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/mlvalues.h caml/misc.h \
   caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
@@ -857,6 +874,9 @@ signals_byt.pic.o: signals_byt.c caml/config.h caml/../../config/m.h \
   caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
   caml/signals_machdep.h
+spacetime.pic.o: spacetime.c caml/fail.h caml/compatibility.h caml/misc.h \
+  caml/config.h caml/../../config/m.h caml/../../config/s.h \
+  caml/mlvalues.h
 stacks.pic.o: stacks.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \
   caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \
@@ -884,7 +904,7 @@ sys.pic.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/instruct.h caml/io.h \
   caml/osdeps.h caml/signals.h caml/stacks.h caml/memory.h caml/gc.h \
   caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
-  caml/sys.h
+  caml/sys.h caml/version.h
 terminfo.pic.o: terminfo.c caml/config.h caml/../../config/m.h \
   caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \
   caml/mlvalues.h caml/fail.h caml/io.h
@@ -892,7 +912,7 @@ unix.pic.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/compatibility.h caml/fail.h caml/misc.h caml/mlvalues.h \
   caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \
-  caml/sys.h
+  caml/sys.h caml/io.h
 weak.pic.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \
   caml/config.h caml/../../config/m.h caml/../../config/s.h \
   caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \

diff --git a/byterun/Makefile.common b/byterun/Makefile.common
index 5bcd6779afeb930594fa4b0638dcf3b1a25e247f..144d3a3e096b141e695e97f7a1a5c0d8d6d21205 100644 (file)
--- a/byterun/Makefile.common
+++ b/byterun/Makefile.common
@@ -26,22 +26,15 @@ COMMONOBJS=\
   compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \
   hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \
   lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o \
-  dynlink.o
+  dynlink.o spacetime.o
 
 PRIMS=\
   alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
   intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \
   signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \
-  dynlink.c backtrace_prim.c backtrace.c
+  dynlink.c backtrace_prim.c backtrace.c spacetime.c
 
-PUBLIC_INCLUDES=\
-  address_class.h alloc.h callback.h config.h custom.h fail.h gc.h \
-  hash.h intext.h \
-  memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h \
-  version.h
-
-
-all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED)
+all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) primitives
 .PHONY: all
 
 all-noruntimed:
@@ -70,9 +63,9 @@ install::
        cd "$(INSTALL_LIBDIR)"; $(RANLIB) libcamlrun.$(A)
        if test -d "$(INSTALL_LIBDIR)/caml"; then : ; \
          else mkdir "$(INSTALL_LIBDIR)/caml"; fi
-       for i in $(PUBLIC_INCLUDES); do \
-         sed -f ../tools/cleanup-header caml/$$i \
-             > "$(INSTALL_LIBDIR)/caml/$$i"; \
+       for i in caml/*.h; do \
+         sed -f ../tools/cleanup-header $$i \
+             > "$(INSTALL_LIBDIR)/$$i"; \
        done
        cp ld.conf "$(INSTALL_LIBDIR)/ld.conf"
 .PHONY: install
@@ -116,7 +109,8 @@ primitives : $(PRIMS)
          | sort | uniq > primitives
 
 prims.c : primitives
-       (echo '#include "caml/mlvalues.h"'; \
+       (echo '#define CAML_INTERNALS'; \
+         echo '#include "caml/mlvalues.h"'; \
         echo '#include "caml/prims.h"'; \
         sed -e 's/.*/extern value &();/' primitives; \
         echo 'c_primitive caml_builtin_cprim[] = {'; \

diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt
index 06b39c6995c1f443a79ab3b7cbe94d55f537a0df..e74bdd9ca55556bd0f56251341f38cd382107c2a 100644 (file)
--- a/byterun/Makefile.nt
+++ b/byterun/Makefile.nt
@@ -16,6 +16,7 @@
 include Makefile.common
 
 CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR)
+DFLAGS=$(CFLAGS) -DDEBUG
 
 ifdef BOOTSTRAPPING_FLEXLINK
 MAKE_OCAMLRUN=$(MKEXE_BOOT)
@@ -33,7 +34,7 @@ ocamlrun$(EXE): libcamlrun.$(A) prims.$(O)
                 $(call SYSLIB,ws2_32) $(EXTRALIBS))
 
 ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O)
-       $(MKEXE) -o ocamlrund$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \
+       $(MKEXE) -o ocamlrund$(EXE) prims.$(O) \
                 $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A)
 
 libcamlrun.$(A): $(OBJS)
@@ -45,8 +46,9 @@ libcamlrund.$(A): $(DOBJS)
 %.$(O): %.c
        $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $<
 
+# It is imperative that there is no space after $(NAME_OBJ_FLAG)
 %.$(DBGO): %.c
-       $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c -o $@ $<
+       $(CC) $(DFLAGS) $(BYTECCDBGCOMPOPTS) -c $(NAME_OBJ_FLAG)$@ $<
 
 .depend.nt: .depend
        rm -f .depend.win32
@@ -59,7 +61,10 @@ libcamlrund.$(A): $(DOBJS)
        echo " caml/freelist.h caml/minor_gc.h caml/osdeps.h caml/signals.h"\
          >> .depend.win32
        cat .depend >> .depend.win32
-       sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' \
+       sed -ne '/\.pic\.o/q' \
+           -e 's/^\(.*\)\.d\.o:/\1.$$(DBGO):/' \
+           -e 's/^\(.*\)\.o:/\1.$$(O):/' \
+           -e p \
            .depend.win32 > .depend.nt
        rm -f .depend.win32
 

diff --git a/byterun/alloc.c b/byterun/alloc.c
index 54b8360835184aeb32ee3020131bad41a53dff8f..7bda39214b4c0a562bd8ba22df4f9f929ed6f72d 100644 (file)
--- a/byterun/alloc.c
+++ b/byterun/alloc.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* 1. Allocation functions doing the same work as the macros in the
       case where [Setup_for_gc] and [Restore_after_gc] are no-ops.
    2. Convenience functions related to allocation.
@@ -64,6 +66,23 @@ CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag)
   return result;
 }
 
+CAMLexport value caml_alloc_small_with_my_or_given_profinfo (mlsize_t wosize,
+  tag_t tag, uintnat profinfo)
+{
+  if (profinfo == 0) {
+    return caml_alloc_small(wosize, tag);
+  }
+  else {
+    value result;
+
+    Assert (wosize > 0);
+    Assert (wosize <= Max_young_wosize);
+    Assert (tag < 256);
+    Alloc_small_with_profinfo (result, wosize, tag, profinfo);
+    return result;
+  }
+}
+
 /* [n] is a number of words (fields) */
 CAMLexport value caml_alloc_tuple(mlsize_t n)
 {
@@ -134,6 +153,23 @@ CAMLexport value caml_alloc_array(value (*funct)(char const *),
   }
 }
 
+/* [len] is a number of floats */
+CAMLprim value caml_alloc_float_array(mlsize_t len)
+{
+  mlsize_t wosize = len * Double_wosize;
+  value result;
+  if (wosize == 0)
+    return Atom(0);
+  else if (wosize <= Max_young_wosize){
+    Alloc_small (result, wosize, Double_array_tag);
+  }else {
+    result = caml_alloc_shr (wosize, Double_array_tag);
+    result = caml_check_urgent_gc (result);
+  }
+  return result;
+}
+
+
 CAMLexport value caml_copy_string_array(char const ** arr)
 {
   return caml_alloc_array(caml_copy_string, arr);

diff --git a/byterun/array.c b/byterun/array.c
index ccfe248814eefafe6255c3e042be592619c7782a..900182db19f2edf3de34c057439d7774a2e555f1 100644 (file)
--- a/byterun/array.c
+++ b/byterun/array.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Operations on arrays */
 #include <string.h>
 #include "caml/alloc.h"
@@ -21,6 +23,9 @@
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 #include "caml/signals.h"
+#include "spacetime.h"
+
+static const mlsize_t mlsize_t_max = -1;
 
 /* returns number of elements (either fields or floats) */
 CAMLexport mlsize_t caml_array_length(value array)
@@ -161,6 +166,7 @@ CAMLprim value caml_make_float_vect(value len)
 }
 
 /* [len] is a [value] representing number of words or floats */
+/* Spacetime profiling assumes that this function is only called from OCaml. */
 CAMLprim value caml_make_vect(value len, value init)
 {
   CAMLparam2 (len, init);
@@ -185,7 +191,9 @@ CAMLprim value caml_make_vect(value len, value init)
   } else {
     if (size > Max_wosize) caml_invalid_argument("Array.make");
     if (size <= Max_young_wosize) {
-      res = caml_alloc_small(size, 0);
+      uintnat profinfo;
+      Get_my_profinfo_with_cached_backtrace(profinfo, size);
+      res = caml_alloc_small_with_my_or_given_profinfo(size, 0, profinfo);
       for (i = 0; i < size; i++) Field(res, i) = init;
     }
     else if (Is_block(init) && Is_young(init)) {
@@ -307,6 +315,7 @@ static value caml_array_gather(intnat num_arrays,
   size = 0;
   isfloat = 0;
   for (i = 0; i < num_arrays; i++) {
+    if (mlsize_t_max - lengths[i] < size) caml_invalid_argument("Array.concat");
     size += lengths[i];
     if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1;
   }
@@ -316,8 +325,8 @@ static value caml_array_gather(intnat num_arrays,
   }
   else if (isfloat) {
     /* This is an array of floats.  We can use memcpy directly. */
+    if (size > Max_wosize/Double_wosize) caml_invalid_argument("Array.concat");
     wsize = size * Double_wosize;
-    if (wsize > Max_wosize) caml_invalid_argument("Array.concat");
     res = caml_alloc(wsize, Double_array_tag);
     for (i = 0, pos = 0; i < num_arrays; i++) {
       memcpy((double *)res + pos,

diff --git a/byterun/backtrace.c b/byterun/backtrace.c
index 1243572285e9080f130b9677f1f25d446a211b49..a5bc780951b743b7cff04c39cdf48848f5892c4d 100644 (file)
--- a/byterun/backtrace.c
+++ b/byterun/backtrace.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Stack backtrace for uncaught exceptions */
 
 #include <stdio.h>
@@ -28,8 +30,8 @@
 /* The table of debug information fragments */
 struct ext_table caml_debug_info;
 
-CAMLexport int caml_backtrace_active = 0;
-CAMLexport int caml_backtrace_pos = 0;
+CAMLexport int32_t caml_backtrace_active = 0;
+CAMLexport int32_t caml_backtrace_pos = 0;
 CAMLexport backtrace_slot * caml_backtrace_buffer = NULL;
 CAMLexport value caml_backtrace_last_exn = Val_unit;
 
@@ -64,13 +66,14 @@ CAMLprim value caml_backtrace_status(value vunit)
 
    note that the test for compiler-inserted raises is slightly redundant:
      (!li->loc_valid && li->loc_is_raise)
-   caml_extract_location_info above guarantees that when li->loc_valid is
+   caml_debuginfo_location guarantees that when li->loc_valid is
    0, then li->loc_is_raise is always 1, so the latter test is
    useless. We kept it to keep code identical to the byterun/
    implementation. */
 static void print_location(struct caml_loc_info * li, int index)
 {
   char * info;
+  char * inlined;
 
   /* Ignore compiler-inserted raise */
   if (!li->loc_valid && li->loc_is_raise) return;
@@ -87,11 +90,16 @@ static void print_location(struct caml_loc_info * li, int index)
     else
       info = "Called from";
   }
+  if (li->loc_is_inlined) {
+    inlined = " (inlined)";
+  } else {
+    inlined = "";
+  }
   if (! li->loc_valid) {
-    fprintf(stderr, "%s unknown location\n", info);
+    fprintf(stderr, "%s unknown location%s\n", info, inlined);
   } else {
-    fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n",
-             info, li->loc_filename, li->loc_lnum,
+    fprintf (stderr, "%s file \"%s\"%s, line %d, characters %d-%d\n",
+             info, li->loc_filename, inlined, li->loc_lnum,
              li->loc_startchr, li->loc_endchr);
   }
 }
@@ -101,6 +109,7 @@ CAMLexport void caml_print_exception_backtrace(void)
 {
   int i;
   struct caml_loc_info li;
+  debuginfo dbg;
 
   if (!caml_debug_info_available()) {
     fprintf(stderr, "(Cannot print stack backtrace: "
@@ -109,8 +118,13 @@ CAMLexport void caml_print_exception_backtrace(void)
   }
 
   for (i = 0; i < caml_backtrace_pos; i++) {
-    caml_extract_location_info(caml_backtrace_buffer[i], &li);
-    print_location(&li, i);
+    for (dbg = caml_debuginfo_extract(caml_backtrace_buffer[i]);
+         dbg != NULL;
+         dbg = caml_debuginfo_next(dbg))
+    {
+      caml_debuginfo_location(dbg, &li);
+      print_location(&li, i);
+    }
   }
 }
 
@@ -146,34 +160,34 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit)
 
     res = caml_alloc(saved_caml_backtrace_pos, 0);
     for (i = 0; i < saved_caml_backtrace_pos; i++) {
-      Field(res, i) =
-        caml_val_raw_backtrace_slot(saved_caml_backtrace_buffer[i]);
+      Field(res, i) = Val_backtrace_slot(saved_caml_backtrace_buffer[i]);
     }
   }
 
   CAMLreturn(res);
 }
 
+#define Val_debuginfo(bslot) (Val_long((uintnat)(bslot)>>1))
+#define Debuginfo_val(vslot) ((debuginfo)(Long_val(vslot) << 1))
+
 /* Convert the raw backtrace to a data structure usable from OCaml */
-CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot)
+static value caml_convert_debuginfo(debuginfo dbg)
 {
-  CAMLparam1(backtrace_slot);
+  CAMLparam0();
   CAMLlocal2(p, fname);
   struct caml_loc_info li;
 
-  if (!caml_debug_info_available())
-    caml_failwith("No debug information available");
-
-  caml_extract_location_info(caml_raw_backtrace_slot_val(backtrace_slot), &li);
+  caml_debuginfo_location(dbg, &li);
 
   if (li.loc_valid) {
     fname = caml_copy_string(li.loc_filename);
-    p = caml_alloc_small(5, 0);
+    p = caml_alloc_small(6, 0);
     Field(p, 0) = Val_bool(li.loc_is_raise);
     Field(p, 1) = fname;
     Field(p, 2) = Val_int(li.loc_lnum);
     Field(p, 3) = Val_int(li.loc_startchr);
     Field(p, 4) = Val_int(li.loc_endchr);
+    Field(p, 5) = Val_bool(li.loc_is_inlined);
   } else {
     p = caml_alloc_small(1, 1);
     Field(p, 0) = Val_bool(li.loc_is_raise);
@@ -182,6 +196,89 @@ CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot)
   CAMLreturn(p);
 }
 
+CAMLprim value caml_convert_raw_backtrace_slot(value slot)
+{
+  if (!caml_debug_info_available())
+    caml_failwith("No debug information available");
+
+  return (caml_convert_debuginfo(Debuginfo_val(slot)));
+}
+
+/* Convert the raw backtrace to a data structure usable from OCaml */
+CAMLprim value caml_convert_raw_backtrace(value bt)
+{
+  CAMLparam1(bt);
+  CAMLlocal1(array);
+  intnat i, index;
+
+  if (!caml_debug_info_available())
+    caml_failwith("No debug information available");
+
+  for (i = 0, index = 0; i < Wosize_val(bt); ++i)
+  {
+    debuginfo dbg;
+    for (dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i)));
+         dbg != NULL;
+         dbg = caml_debuginfo_next(dbg))
+      index++;
+  }
+
+  array = caml_alloc(index, 0);
+
+  for (i = 0, index = 0; i < Wosize_val(bt); ++i)
+  {
+    debuginfo dbg;
+    for (dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i)));
+         dbg != NULL;
+         dbg = caml_debuginfo_next(dbg))
+    {
+      Store_field(array, index, caml_convert_debuginfo(dbg));
+      index++;
+    }
+  }
+
+  CAMLreturn(array);
+}
+
+CAMLprim value caml_raw_backtrace_length(value bt)
+{
+  return Val_int(Wosize_val(bt));
+}
+
+CAMLprim value caml_raw_backtrace_slot(value bt, value index)
+{
+  uintnat i;
+  debuginfo dbg;
+
+  i = Long_val(index);
+  if (i >= Wosize_val(bt))
+    caml_invalid_argument("Printexc.get_raw_backtrace_slot: "
+                          "index out of bounds");
+  dbg = caml_debuginfo_extract(Backtrace_slot_val(Field(bt, i)));
+  return Val_debuginfo(dbg);
+}
+
+CAMLprim value caml_raw_backtrace_next_slot(value slot)
+{
+  debuginfo dbg;
+
+  CAMLparam1(slot);
+  CAMLlocal1(v);
+
+  dbg = Debuginfo_val(slot);
+  dbg = caml_debuginfo_next(dbg);
+
+  if (dbg == NULL)
+    v = Val_int(0); /* None */
+  else
+  {
+    v = caml_alloc(1, 0);
+    Field(v, 0) = Val_debuginfo(dbg);
+  }
+
+  CAMLreturn(v);
+}
+
 /* the function below is deprecated: we previously returned directly
    the OCaml-usable representation, instead of the raw backtrace as an
    abstract type, but this has a large performance overhead if you
@@ -197,13 +294,15 @@ CAMLprim value caml_get_exception_backtrace(value unit)
   intnat i;
 
   if (!caml_debug_info_available()) {
-      res = Val_int(0); /* None */
+    res = Val_int(0); /* None */
   } else {
     backtrace = caml_get_exception_raw_backtrace(Val_unit);
 
     arr = caml_alloc(Wosize_val(backtrace), 0);
     for (i = 0; i < Wosize_val(backtrace); i++) {
-      Store_field(arr, i, caml_convert_raw_backtrace_slot(Field(backtrace, i)));
+      backtrace_slot slot = Backtrace_slot_val(Field(backtrace, i));
+      debuginfo dbg = caml_debuginfo_extract(slot);
+      Store_field(arr, i, caml_convert_debuginfo(dbg));
     }
 
     res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */

diff --git a/byterun/backtrace_prim.c b/byterun/backtrace_prim.c
index 081c97fac7b557f286c854d160668012caeb5bcf..c81955a4537bb5a895e8506ed4fed513fdcdd770 100644 (file)
--- a/byterun/backtrace_prim.c
+++ b/byterun/backtrace_prim.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Stack backtrace for uncaught exceptions */
 
 #include <fcntl.h>
@@ -247,24 +249,6 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise)
   }
 }
 
-/* In order to prevent the GC from walking through the debug
-   information (which have no headers), we transform code pointers to
-   31/63 bits ocaml integers by shifting them by 1 to the right. We do
-   not lose information as code pointers are aligned.
-
-   In particular, we do not need to use [caml_modify] when setting
-   an array element with such a value.
-*/
-value caml_val_raw_backtrace_slot(backtrace_slot pc)
-{
-  return Val_long ((uintnat)pc >> 1);
-}
-
-backtrace_slot caml_raw_backtrace_slot_val(value v)
-{
-  return ((backtrace_slot)(Long_val(v) << 1));
-}
-
 /* returns the next frame pointer (or NULL if none is available);
    updates *sp to point to the following one, and *trsp to the next
    trap frame, which we will skip when we reach it  */
@@ -323,7 +307,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value)
     for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
       code_t p = caml_next_frame_pointer(&sp, &trsp);
       Assert(p != NULL);
-      Store_field(trace, trace_pos, caml_val_raw_backtrace_slot(p));
+      Field(trace, trace_pos) = Val_backtrace_slot(p);
     }
   }
 
@@ -436,10 +420,10 @@ static struct ev_info *event_for_location(code_t pc)
 
 /* Extract location information for the given PC */
 
-void caml_extract_location_info(backtrace_slot slot,
-                                /*out*/ struct caml_loc_info * li)
+void caml_debuginfo_location(debuginfo dbg,
+                             /*out*/ struct caml_loc_info * li)
 {
-  code_t pc = slot;
+  code_t pc = dbg;
   struct ev_info *event = event_for_location(pc);
   li->loc_is_raise =
     caml_is_instruction(*pc, RAISE) ||
@@ -449,8 +433,20 @@ void caml_extract_location_info(backtrace_slot slot,
     return;
   }
   li->loc_valid = 1;
+  li->loc_is_inlined = 0;
   li->loc_filename = event->ev_filename;
   li->loc_lnum = event->ev_lnum;
   li->loc_startchr = event->ev_startchr;
   li->loc_endchr = event->ev_endchr;
 }
+
+debuginfo caml_debuginfo_extract(backtrace_slot slot)
+{
+  return (debuginfo)slot;
+}
+
+debuginfo caml_debuginfo_next(debuginfo dbg)
+{
+  /* No inlining in bytecode */
+  return NULL;
+}

diff --git a/byterun/callback.c b/byterun/callback.c
index 7697edccfb52e739dd710c32a020498d39cf7410..bef4b3df501e27be2a78a0fb9eafd09b40109344 100644 (file)
--- a/byterun/callback.c
+++ b/byterun/callback.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Callbacks from C to OCaml */
 
 #include <string.h>

diff --git a/byterun/caml/alloc.h b/byterun/caml/alloc.h
index 64a250d785a42654adf10d23fa5d41d07c55e48f..5bd3d7ce7633f53d3f76bd93412164610d1c9ea7 100644 (file)
--- a/byterun/caml/alloc.h
+++ b/byterun/caml/alloc.h
@@ -30,6 +30,7 @@ extern "C" {
 CAMLextern value caml_alloc (mlsize_t wosize, tag_t);
 CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t);
 CAMLextern value caml_alloc_tuple (mlsize_t wosize);
+CAMLextern value caml_alloc_float_array (mlsize_t len);
 CAMLextern value caml_alloc_string (mlsize_t len);  /* len in bytes (chars) */
 CAMLextern value caml_copy_string (char const *);
 CAMLextern value caml_copy_string_array (char const **);
@@ -41,6 +42,11 @@ CAMLextern value caml_alloc_array (value (*funct) (char const *),
                                    char const ** array);
 CAMLextern value caml_alloc_sprintf(const char * format, ...);
 
+CAMLextern value caml_alloc_with_profinfo (mlsize_t, tag_t, intnat);
+CAMLextern value caml_alloc_small_with_my_or_given_profinfo (
+  mlsize_t, tag_t, uintnat);
+CAMLextern value caml_alloc_small_with_profinfo (mlsize_t, tag_t, intnat);
+
 typedef void (*final_fun)(value);
 CAMLextern value caml_alloc_final (mlsize_t wosize,
                                    final_fun, /*finalization function*/
@@ -49,6 +55,21 @@ CAMLextern value caml_alloc_final (mlsize_t wosize,
 
 CAMLextern int caml_convert_flag_list (value, int *);
 
+/* Convenience functions to deal with unboxable types. */
+static inline value caml_alloc_unboxed (value arg) { return arg; }
+static inline value caml_alloc_boxed (value arg) {
+  value result = caml_alloc_small (1, 0);
+  Field (result, 0) = arg;
+  return result;
+}
+static inline value caml_field_unboxed (value arg) { return arg; }
+static inline value caml_field_boxed (value arg) { return Field (arg, 0); }
+
+/* Unannotated unboxable types are boxed by default. (may change in the
+   future) */
+#define caml_alloc_unboxable caml_alloc_boxed
+#define caml_field_unboxable caml_field_boxed
+
 #ifdef __cplusplus
 }
 #endif

diff --git a/byterun/caml/backtrace.h b/byterun/caml/backtrace.h
index a1630f2b5be4c013a8c4668943ba8cdc1d820a24..e9acf33cf489418ad5636f8cd4335a69dd0afea7 100644 (file)
--- a/byterun/caml/backtrace.h
+++ b/byterun/caml/backtrace.h
@@ -16,6 +16,8 @@
 #ifndef CAML_BACKTRACE_H
 #define CAML_BACKTRACE_H
 
+#ifdef CAML_INTERNALS
+
 #include "mlvalues.h"
 #include "exec.h"
 
@@ -129,4 +131,6 @@ CAMLextern void caml_print_exception_backtrace(void);
 void caml_init_backtrace(void);
 CAMLexport void caml_init_debug_info(void);
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_BACKTRACE_H */

diff --git a/byterun/caml/backtrace_prim.h b/byterun/caml/backtrace_prim.h
index c59dbc331f699c13e7ace5b9e2ebd11ad6d1d8e8..025242d0011a79554a2ea30b9afacd8bb69dee94 100644 (file)
--- a/byterun/caml/backtrace_prim.h
+++ b/byterun/caml/backtrace_prim.h
@@ -16,6 +16,8 @@
 #ifndef CAML_BACKTRACE_PRIM_H
 #define CAML_BACKTRACE_PRIM_H
 
+#ifdef CAML_INTERNALS
+
 #include "backtrace.h"
 
 /* Backtrace generation is split in [backtrace.c] and [backtrace_prim.c].
@@ -36,22 +38,37 @@ struct caml_loc_info {
   int loc_lnum;
   int loc_startchr;
   int loc_endchr;
+  int loc_is_inlined;
 };
 
+/* When compiling with -g, backtrace slots have debug info associated.
+ * When a call is inlined in native mode, debuginfos form a linked list.
+ */
+typedef void * debuginfo;
+
 /* Check availability of debug information before extracting a trace.
  * Relevant for bytecode, always true for native code. */
 int caml_debug_info_available(void);
 
+/* Return debuginfo associated to a slot or NULL. */
+debuginfo caml_debuginfo_extract(backtrace_slot slot);
+
+/* In case of an inlined call return next debuginfo or NULL otherwise. */
+debuginfo caml_debuginfo_next(debuginfo dbg);
+
 /* Extract locations from backtrace_slot */
-void caml_extract_location_info(backtrace_slot pc,
-                                /*out*/ struct caml_loc_info * li);
+void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li);
+
+/* In order to prevent the GC from walking through the debug
+   information (which have no headers), we transform slots to 31/63 bits
+   ocaml integers by shifting them by 1 to the right. We do not lose
+   information as slots are aligned.
 
-/* Expose a [backtrace_slot] as a OCaml value of type [raw_backtrace_slot].
- * The value returned should be an immediate and not an OCaml block, so that it
- * is safe to store using direct assignment and [Field], and not [Store_field] /
- * [caml_modify].  */
-value caml_val_raw_backtrace_slot(backtrace_slot pc);
-backtrace_slot caml_raw_backtrace_slot_val(value slot);
+   In particular, we do not need to use [caml_modify] when setting
+   an array element with such a value.
+ */
+#define Val_backtrace_slot(bslot) (Val_long(((uintnat)(bslot))>>1))
+#define Backtrace_slot_val(vslot) ((backtrace_slot)(Long_val(vslot) << 1))
 
 #define BACKTRACE_BUFFER_SIZE 1024
 
@@ -66,4 +83,6 @@ backtrace_slot caml_raw_backtrace_slot_val(value slot);
  * explicitly.
  */
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_BACKTRACE_PRIM_H */

diff --git a/byterun/caml/compact.h b/byterun/caml/compact.h
index 7295058329e851125c1434280163f048e958eb32..4f98fb12b7941416534c2e59d2a3a7635c3dfeca 100644 (file)
--- a/byterun/caml/compact.h
+++ b/byterun/caml/compact.h
@@ -16,12 +16,16 @@
 #ifndef CAML_COMPACT_H
 #define CAML_COMPACT_H
 
+#ifdef CAML_INTERNALS
 
 #include "config.h"
 #include "misc.h"
+#include "mlvalues.h"
 
-extern void caml_compact_heap (void);
-extern void caml_compact_heap_maybe (void);
+void caml_compact_heap (void);
+void caml_compact_heap_maybe (void);
+void invert_root (value v, value *p);
 
+#endif /* CAML_INTERNALS */
 
 #endif /* CAML_COMPACT_H */

diff --git a/byterun/caml/compare.h b/byterun/caml/compare.h
index d6456f46cdc402a42fefcc3b47e1baeecf85f239..54b71581b9a9543583a8fad5af0081f206db2e14 100644 (file)
--- a/byterun/caml/compare.h
+++ b/byterun/caml/compare.h
@@ -16,6 +16,10 @@
 #ifndef CAML_COMPARE_H
 #define CAML_COMPARE_H
 
+#ifdef CAML_INTERNALS
+
 CAMLextern int caml_compare_unordered;
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_COMPARE_H */

diff --git a/byterun/caml/custom.h b/byterun/caml/custom.h
index a3119d0f3d93e434329435fc3a388324b4c45fd7..6bc3aa9528ebb861d5d548486400c1bc227449c1 100644 (file)
--- a/byterun/caml/custom.h
+++ b/byterun/caml/custom.h
@@ -58,13 +58,13 @@ CAMLextern void caml_register_custom_operations(struct custom_operations * ops);
 CAMLextern int caml_compare_unordered;
   /* Used by custom comparison to report unordered NaN-like cases. */
 
-/* <private> */
+#ifdef CAML_INTERNALS
 extern struct custom_operations * caml_find_custom_operations(char * ident);
 extern struct custom_operations *
           caml_final_custom_operations(void (*fn)(value));
 
 extern void caml_init_custom_operations(void);
-/* </private> */
+#endif /* CAML_INTERNALS */
 
 #ifdef __cplusplus
 }

diff --git a/byterun/caml/debugger.h b/byterun/caml/debugger.h
index 00a977497eefd063fdff11f8fc5471c5f8018f15..c98f35a8d12d20763ddefb292904d3708bffdc57 100644 (file)
--- a/byterun/caml/debugger.h
+++ b/byterun/caml/debugger.h
@@ -18,6 +18,8 @@
 #ifndef CAML_DEBUGGER_H
 #define CAML_DEBUGGER_H
 
+#ifdef CAML_INTERNALS
+
 #include "misc.h"
 #include "mlvalues.h"
 
@@ -110,4 +112,6 @@ enum debugger_reply {
   /* Program exited due to a stray exception. */
 };
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_DEBUGGER_H */

diff --git a/byterun/caml/dynlink.h b/byterun/caml/dynlink.h
index 3c5b9b73ed4b869626f3cf1e838f518abc3af89d..0eed7e7fa1d112ac5fb3bd4ecdcaa382c0f39443 100644 (file)
--- a/byterun/caml/dynlink.h
+++ b/byterun/caml/dynlink.h
@@ -18,6 +18,8 @@
 #ifndef CAML_DYNLINK_H
 #define CAML_DYNLINK_H
 
+#ifdef CAML_INTERNALS
+
 #include "misc.h"
 
 /* Build the table of primitives, given a search path, a list
@@ -35,4 +37,6 @@ extern struct ext_table caml_shared_libs_path;
    Used for executables generated by ocamlc -output-obj. */
 extern void caml_build_primitive_table_builtin(void);
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_DYNLINK_H */

diff --git a/byterun/caml/exec.h b/byterun/caml/exec.h
index eee7596d2256e8ae5fe2a76d33727a42caa0be0f..f39747acf8a77a4a4c7e469913048665d19fd285 100644 (file)
--- a/byterun/caml/exec.h
+++ b/byterun/caml/exec.h
@@ -18,6 +18,8 @@
 #ifndef CAML_EXEC_H
 #define CAML_EXEC_H
 
+#ifdef CAML_INTERNALS
+
 /* Executable bytecode files are composed of a number of sections,
    identified by 4-character names.  A table of contents at the
    end of the file lists the section names along with their sizes,
@@ -58,5 +60,6 @@ struct exec_trailer {
 
 #define EXEC_MAGIC "Caml1999X011"
 
+#endif /* CAML_INTERNALS */
 
 #endif /* CAML_EXEC_H */

diff --git a/byterun/caml/fail.h b/byterun/caml/fail.h
index aa417b75046504d0a0ff67351f39141172995f12..07cb37d18357c879d6db279b9afa8551b9ea2868 100644 (file)
--- a/byterun/caml/fail.h
+++ b/byterun/caml/fail.h
@@ -16,9 +16,9 @@
 #ifndef CAML_FAIL_H
 #define CAML_FAIL_H
 
-/* <private> */
+#ifdef CAML_INTERNALS
 #include <setjmp.h>
-/* </private> */
+#endif /* CAML_INTERNALS */
 
 #ifndef CAML_NAME_SPACE
 #include "compatibility.h"
@@ -26,7 +26,7 @@
 #include "misc.h"
 #include "mlvalues.h"
 
-/* <private> */
+#ifdef CAML_INTERNALS
 #define OUT_OF_MEMORY_EXN 0     /* "Out_of_memory" */
 #define SYS_ERROR_EXN 1         /* "Sys_error" */
 #define FAILURE_EXN 2           /* "Failure" */
@@ -56,7 +56,7 @@ CAMLextern struct longjmp_buffer * caml_external_raise;
 extern value caml_exn_bucket;
 int caml_is_special_exception(value exn);
 
-/* </private> */
+#endif /* CAML_INTERNALS */
 
 #ifdef __cplusplus
 extern "C" {

diff --git a/byterun/caml/finalise.h b/byterun/caml/finalise.h
index 9fbac8262b27909ac39785a08e7fca30d6dcca41..5315ac215611f779464694f99e515d1b4c0f8641 100644 (file)
--- a/byterun/caml/finalise.h
+++ b/byterun/caml/finalise.h
@@ -16,14 +16,21 @@
 #ifndef CAML_FINALISE_H
 #define CAML_FINALISE_H
 
+#ifdef CAML_INTERNALS
+
 #include "roots.h"
 
-void caml_final_update (void);
+void caml_final_update_mark_phase (void);
+void caml_final_update_clean_phase (void);
 void caml_final_do_calls (void);
-void caml_final_do_strong_roots (scanning_action f);
-void caml_final_do_weak_roots (scanning_action f);
-void caml_final_do_young_roots (scanning_action f);
+void caml_final_do_roots (scanning_action f);
+void caml_final_invert_finalisable_values ();
+void caml_final_oldify_young_roots ();
 void caml_final_empty_young (void);
+void caml_final_update_minor_roots(void);
 value caml_final_register (value f, value v);
+void caml_final_invariant_check(void);
+
+#endif /* CAML_INTERNALS */
 
 #endif /* CAML_FINALISE_H */

diff --git a/byterun/caml/fix_code.h b/byterun/caml/fix_code.h
index 9c39d481f9a61e687c925b67ce3b8835fb55fbde..7e5633d6d311cfa6fca818a54bd2ea3a3860ccc1 100644 (file)
--- a/byterun/caml/fix_code.h
+++ b/byterun/caml/fix_code.h
@@ -18,6 +18,7 @@
 #ifndef CAML_FIX_CODE_H
 #define CAML_FIX_CODE_H
 
+#ifdef CAML_INTERNALS
 
 #include "config.h"
 #include "misc.h"
@@ -39,4 +40,6 @@ extern char * caml_instr_base;
 void caml_thread_code (code_t code, asize_t len);
 #endif
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_FIX_CODE_H */

diff --git a/byterun/caml/freelist.h b/byterun/caml/freelist.h
index f6c812ee4e37e92cea1f60f61ecd026c8445aa77..54e0e822f4731f681c0aaabf98a8f194fe5f608d 100644 (file)
--- a/byterun/caml/freelist.h
+++ b/byterun/caml/freelist.h
@@ -18,6 +18,7 @@
 #ifndef CAML_FREELIST_H
 #define CAML_FREELIST_H
 
+#ifdef CAML_INTERNALS
 
 #include "misc.h"
 #include "mlvalues.h"
@@ -32,5 +33,6 @@ void caml_fl_add_blocks (value);
 void caml_make_free_blocks (value *, mlsize_t wsz, int, int);
 void caml_set_allocation_policy (uintnat);
 
+#endif /* CAML_INTERNALS */
 
 #endif /* CAML_FREELIST_H */

diff --git a/byterun/caml/gc.h b/byterun/caml/gc.h
index a57a2bc2161be29f51e7a425a7c4b062e3747d7c..776ddc7783ea12cf830e56ac1c44e6b90b7c6713 100644 (file)
--- a/byterun/caml/gc.h
+++ b/byterun/caml/gc.h
@@ -46,6 +46,23 @@
                     + (tag_t) (tag)))                                         \
       )
 
+#ifdef WITH_SPACETIME
+struct ext_table;
+extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat);
+#define Make_header_with_profinfo(wosize, tag, color, profinfo)               \
+      (Make_header(wosize, tag, color)                                        \
+        | ((((intnat) profinfo) & PROFINFO_MASK) << PROFINFO_SHIFT)           \
+      )
+#define Make_header_allocated_here(wosize, tag, color)                        \
+      (Make_header_with_profinfo(wosize, tag, color,                          \
+        caml_spacetime_my_profinfo(NULL, wosize))                             \
+      )
+#else
+#define Make_header_allocated_here Make_header
+#define Make_header_with_profinfo(wosize, tag, color, profinfo) \
+  Make_header(wosize | (profinfo & (intnat) 0), tag, color)
+#endif
+
 #define Is_white_val(val) (Color_val(val) == Caml_white)
 #define Is_gray_val(val) (Color_val(val) == Caml_gray)
 #define Is_blue_val(val) (Color_val(val) == Caml_blue)

diff --git a/byterun/caml/gc_ctrl.h b/byterun/caml/gc_ctrl.h
index 924a1091ad4c7e6f6742df7827fe39262078763d..ebf1a40b509930241e69797c7b4bafd3988f383a 100644 (file)
--- a/byterun/caml/gc_ctrl.h
+++ b/byterun/caml/gc_ctrl.h
@@ -16,6 +16,8 @@
 #ifndef CAML_GC_CTRL_H
 #define CAML_GC_CTRL_H
 
+#ifdef CAML_INTERNALS
+
 #include "misc.h"
 
 extern double
@@ -45,8 +47,12 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr,
                    uintnat percent_fr, uintnat percent_m, uintnat window);
 
 
+CAMLextern value caml_gc_stat(value v);
+
 #ifdef DEBUG
 void caml_heap_check (void);
 #endif
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_GC_CTRL_H */

diff --git a/byterun/caml/globroots.h b/byterun/caml/globroots.h
index b580e6de03c358d803e04dba2c4d92d298fde756..10fe66f5b7784cb5e2031a494c4b831256064567 100644 (file)
--- a/byterun/caml/globroots.h
+++ b/byterun/caml/globroots.h
@@ -18,10 +18,14 @@
 #ifndef CAML_GLOBROOTS_H
 #define CAML_GLOBROOTS_H
 
+#ifdef CAML_INTERNALS
+
 #include "mlvalues.h"
 #include "roots.h"
 
 void caml_scan_global_roots(scanning_action f);
 void caml_scan_global_young_roots(scanning_action f);
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_GLOBROOTS_H */

diff --git a/byterun/caml/hooks.h b/byterun/caml/hooks.h
new file mode 100644 (file)
index 0000000..c981426
--- /dev/null
+++ b/byterun/caml/hooks.h
@@ -0,0 +1,42 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                    Fabrice Le Fessant, INRIA de Paris                  */
+/*                                                                        */
+/*   Copyright 2016 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_HOOKS_H
+#define CAML_HOOKS_H
+
+#include "misc.h"
+#include "memory.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef CAML_INTERNALS
+
+#ifdef NATIVE_CODE
+
+/* executed just before calling the entry point of a dynamically
+   loaded native code module. */
+CAMLextern void (*caml_natdynlink_hook)(void* handle, char* unit);
+
+#endif /* NATIVE_CODE */
+
+#endif /* CAML_INTERNALS */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* CAML_HOOKS_H */

diff --git a/byterun/caml/instrtrace.h b/byterun/caml/instrtrace.h
index 9ff363fb2ea16662c63d3a1d92cc2f8f668098be..2e42a80a0a3bab7913d505e55ea6f0b137a4775b 100644 (file)
--- a/byterun/caml/instrtrace.h
+++ b/byterun/caml/instrtrace.h
@@ -18,6 +18,7 @@
 #ifndef _instrtrace_
 #define _instrtrace_
 
+#ifdef CAML_INTERNALS
 
 #include "mlvalues.h"
 #include "misc.h"
@@ -28,4 +29,7 @@ void caml_disasm_instr (code_t pc);
 void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f);
 void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen,
                              FILE * f);
+
+#endif /* CAML_INTERNALS */
+
 #endif

diff --git a/byterun/caml/instruct.h b/byterun/caml/instruct.h
index 94816bca392864f5a9ff3daef773a512d72df41d..737983333255efb4e35e48c3b2d61276afba0f7d 100644 (file)
--- a/byterun/caml/instruct.h
+++ b/byterun/caml/instruct.h
@@ -18,6 +18,8 @@
 #ifndef CAML_INSTRUCT_H
 #define CAML_INSTRUCT_H
 
+#ifdef CAML_INTERNALS
+
 enum instructions {
   ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7,
   ACC, PUSH,
@@ -60,5 +62,6 @@ enum instructions {
   RERAISE, RAISE_NOTRACE,
 FIRST_UNIMPLEMENTED_OP};
 
+#endif /* CAML_INTERNALS */
 
 #endif /* CAML_INSTRUCT_H */

diff --git a/byterun/caml/int64_emul.h b/byterun/caml/int64_emul.h
index 970bfe49038316fb05356a1f1bf971b8acf0b197..c1cddcc05d0cd7dbf0598c798e88d04f2f1c7085 100644 (file)
--- a/byterun/caml/int64_emul.h
+++ b/byterun/caml/int64_emul.h
@@ -19,6 +19,8 @@
 #ifndef CAML_INT64_EMUL_H
 #define CAML_INT64_EMUL_H
 
+#ifdef CAML_INTERNALS
+
 #include <math.h>
 
 #ifdef ARCH_BIG_ENDIAN
@@ -286,4 +288,6 @@ static int64_t I64_bswap(int64_t x)
   return res;
 }
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_INT64_EMUL_H */

diff --git a/byterun/caml/int64_format.h b/byterun/caml/int64_format.h
index e1570e374b65f0a39d290833813ea1d265cafdf7..40250ed9ef799dcbc686937be8aca3fbeccdc223 100644 (file)
--- a/byterun/caml/int64_format.h
+++ b/byterun/caml/int64_format.h
@@ -19,6 +19,8 @@
 #ifndef CAML_INT64_FORMAT_H
 #define CAML_INT64_FORMAT_H
 
+#ifdef CAML_INTERNALS
+
 static void I64_format(char * buffer, char * fmt, int64_t x)
 {
   static char conv_lower[] = "0123456789abcdef";
@@ -104,4 +106,6 @@ static void I64_format(char * buffer, char * fmt, int64_t x)
   *p = 0;
 }
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_INT64_FORMAT_H */

diff --git a/byterun/caml/int64_native.h b/byterun/caml/int64_native.h
index 269811c598e9e66eb8a0f0f24573cda11fa20d15..7df66511cf035b62678816b9f5d6aa578ce88489 100644 (file)
--- a/byterun/caml/int64_native.h
+++ b/byterun/caml/int64_native.h
@@ -20,6 +20,8 @@
 #ifndef CAML_INT64_NATIVE_H
 #define CAML_INT64_NATIVE_H
 
+#ifdef CAML_INTERNALS
+
 #define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo))
 #define I64_split(x,hi,lo) (hi = (uint32_t)((x)>>32), lo = (uint32_t)(x))
 #define I64_compare(x,y) (((x) > (y)) - ((x) < (y)))
@@ -60,4 +62,6 @@
                       (((x) & 0x00FF000000000000ULL) >> 40) | \
                       (((x) & 0xFF00000000000000ULL) >> 56))
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_INT64_NATIVE_H */

diff --git a/byterun/caml/interp.h b/byterun/caml/interp.h
index 120c2d95934f4acce99a8ac318a26e411ac57fce..d1ebdc01a57c40bf1e92d8c8d9738af304dd6ad4 100644 (file)
--- a/byterun/caml/interp.h
+++ b/byterun/caml/interp.h
@@ -18,6 +18,8 @@
 #ifndef CAML_INTERP_H
 #define CAML_INTERP_H
 
+#ifdef CAML_INTERNALS
+
 #include "misc.h"
 #include "mlvalues.h"
 
@@ -30,4 +32,6 @@ void caml_prepare_bytecode(code_t prog, asize_t prog_size);
 /* tell the runtime that a bytecode program is no more needed */
 void caml_release_bytecode(code_t prog, asize_t prog_size);
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_INTERP_H */

diff --git a/byterun/caml/intext.h b/byterun/caml/intext.h
index 3deaf3a062ac0ccf2426edb0ef2ebefb1c95a355..673c6fc0a1779f0efeb52c9ac4bbe141e6776e19 100644 (file)
--- a/byterun/caml/intext.h
+++ b/byterun/caml/intext.h
@@ -24,7 +24,7 @@
 #include "misc.h"
 #include "mlvalues.h"
 
-/* <private> */
+#ifdef CAML_INTERNALS
 #include "io.h"
 
 /* Magic number */
@@ -103,7 +103,7 @@
 void caml_output_val (struct channel * chan, value v, value flags);
   /* Output [v] with flags [flags] on the channel [chan]. */
 
-/* </private> */
+#endif /* CAML_INTERNALS */
 
 #ifdef __cplusplus
 extern "C" {
@@ -122,10 +122,21 @@ CAMLextern intnat caml_output_value_to_block(value v, value flags,
      in bytes.  Return the number of bytes actually written in buffer.
      Raise [Failure] if buffer is too short. */
 
-/* <private> */
+#ifdef CAML_INTERNALS
 value caml_input_val (struct channel * chan);
   /* Read a structured value from the channel [chan]. */
-/* </private> */
+
+extern value caml_input_value_to_outside_heap (value channel);
+  /* As for [caml_input_value], but the value is unmarshalled into
+     malloc blocks that are not added to the heap.  Not for the
+     casual user. */
+
+extern int caml_extern_allow_out_of_heap;
+  /* Permit the marshaller to traverse structures that look like OCaml
+     values but do not live in the OCaml heap. */
+
+extern value caml_output_value(value vchan, value v, value flags);
+#endif /* CAML_INTERNALS */
 
 CAMLextern value caml_input_val_from_string (value str, intnat ofs);
   /* Read a structured value from the OCaml string [str], starting
@@ -172,7 +183,7 @@ CAMLextern void caml_deserialize_block_8(void * data, intnat len);
 CAMLextern void caml_deserialize_block_float_8(void * data, intnat len);
 CAMLextern void caml_deserialize_error(char * msg);
 
-/* <private> */
+#ifdef CAML_INTERNALS
 
 /* Auxiliary stuff for sending code pointers */
 
@@ -183,9 +194,11 @@ struct code_fragment {
   char digest_computed;
 };
 
+CAMLextern struct code_fragment * caml_extern_find_code(char *addr);
+
 struct ext_table caml_code_fragments_table;
 
-/* </private> */
+#endif /* CAML_INTERNALS */
 
 #ifdef __cplusplus
 }

diff --git a/byterun/caml/io.h b/byterun/caml/io.h
index e17b3e9a761d079961547fde8b454fd25c12d691..f388bd9fb499e05206ba627234fcb2b9b3d36b5a 100644 (file)
--- a/byterun/caml/io.h
+++ b/byterun/caml/io.h
@@ -18,6 +18,8 @@
 #ifndef CAML_IO_H
 #define CAML_IO_H
 
+#ifdef CAML_INTERNALS
+
 #include "misc.h"
 #include "mlvalues.h"
 
@@ -51,7 +53,10 @@ struct channel {
 };
 
 enum {
-  CHANNEL_FLAG_FROM_SOCKET = 1  /* For Windows */
+  CHANNEL_FLAG_FROM_SOCKET = 1,  /* For Windows */
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  CHANNEL_FLAG_BLOCKING_WRITE = 2,
+#endif
 };
 
 /* For an output channel:
@@ -63,12 +68,12 @@ enum {
 /* Functions and macros that can be called from C.  Take arguments of
    type struct channel *.  No locking is performed. */
 
-#define putch(channel, ch) do{                                            \
+#define caml_putch(channel, ch) do{                                       \
   if ((channel)->curr >= (channel)->end) caml_flush_partial(channel);     \
   *((channel)->curr)++ = (ch);                                            \
 }while(0)
 
-#define getch(channel)                                                      \
+#define caml_getch(channel)                                                 \
   ((channel)->curr >= (channel)->max                                        \
    ? caml_refill(channel)                                                   \
    : (unsigned char) *((channel)->curr)++)
@@ -88,7 +93,7 @@ CAMLextern void caml_really_putblock (struct channel *, char *, intnat);
 CAMLextern unsigned char caml_refill (struct channel *);
 CAMLextern uint32_t caml_getword (struct channel *);
 CAMLextern int caml_getblock (struct channel *, char *, intnat);
-CAMLextern int caml_really_getblock (struct channel *, char *, intnat);
+CAMLextern intnat caml_really_getblock (struct channel *, char *, intnat);
 
 /* Extract a struct channel * from the heap object representing it */
 
@@ -115,4 +120,6 @@ CAMLextern struct channel * caml_all_opened_channels;
 #define Val_file_offset(fofs) caml_copy_int64(fofs)
 #define File_offset_val(v) ((file_offset) Int64_val(v))
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_IO_H */

diff --git a/byterun/caml/major_gc.h b/byterun/caml/major_gc.h
index 15d46e48e241d6e78326e352822639aeb9851312..98909c0ac80ae8eafdb95e15503bf0eb17e93da9 100644 (file)
--- a/byterun/caml/major_gc.h
+++ b/byterun/caml/major_gc.h
@@ -16,6 +16,7 @@
 #ifndef CAML_MAJOR_GC_H
 #define CAML_MAJOR_GC_H
 
+#ifdef CAML_INTERNALS
 
 #include "freelist.h"
 #include "misc.h"
@@ -68,6 +69,10 @@ int caml_major_ring_index;
 double caml_major_work_credit;
 extern double caml_gc_clock;
 
+/* [caml_major_gc_hook] is called just between the end of the mark
+   phase and the beginning of the sweep phase of the major GC */
+CAMLextern void (*caml_major_gc_hook)(void);
+
 void caml_init_major_heap (asize_t);           /* size in bytes */
 asize_t caml_clip_heap_chunk_wsz (asize_t wsz);
 void caml_darken (value, value *);
@@ -76,5 +81,6 @@ void major_collection (void);
 void caml_finish_major_cycle (void);
 void caml_set_major_window (int);
 
+#endif /* CAML_INTERNALS */
 
 #endif /* CAML_MAJOR_GC_H */

diff --git a/byterun/caml/md5.h b/byterun/caml/md5.h
index f88fa8bf95ac52bead534d0659c4c006843423e2..e83c16cd2184c79ddcd53df1dc4d6bc5f163c5a4 100644 (file)
--- a/byterun/caml/md5.h
+++ b/byterun/caml/md5.h
@@ -18,6 +18,7 @@
 #ifndef CAML_MD5_H
 #define CAML_MD5_H
 
+#ifdef CAML_INTERNALS
 
 #include "mlvalues.h"
 #include "io.h"
@@ -27,6 +28,8 @@ CAMLextern value caml_md5_chan (value vchan, value len);
 CAMLextern void caml_md5_block(unsigned char digest[16],
                                void * data, uintnat len);
 
+CAMLextern value caml_md5_channel(struct channel *chan, intnat toread);
+
 struct MD5Context {
         uint32_t buf[4];
         uint32_t bits[2];
@@ -39,5 +42,6 @@ CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf,
 CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx);
 CAMLextern void caml_MD5Transform (uint32_t *buf, uint32_t *in);
 
+#endif /* CAML_INTERNALS */
 
 #endif /* CAML_MD5_H */

diff --git a/byterun/caml/memory.h b/byterun/caml/memory.h
index 9a1287c65e54402c4412e3f239afcc9b719241d0..608b702a7bd5503be7baa5cdbb23afb0234cbf00 100644 (file)
--- a/byterun/caml/memory.h
+++ b/byterun/caml/memory.h
@@ -22,11 +22,11 @@
 #include "compatibility.h"
 #endif
 #include "config.h"
-/* <private> */
+#ifdef CAML_INTERNALS
 #include "gc.h"
 #include "major_gc.h"
 #include "minor_gc.h"
-/* </private> */
+#endif /* CAML_INTERNALS */
 #include "misc.h"
 #include "mlvalues.h"
 
@@ -36,6 +36,16 @@ extern "C" {
 
 
 CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t);
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+CAMLextern value caml_alloc_shr_with_profinfo (mlsize_t, tag_t, intnat);
+CAMLextern value caml_alloc_shr_preserving_profinfo (mlsize_t, tag_t,
+  header_t);
+#else
+#define caml_alloc_shr_with_profinfo(size, tag, profinfo) \
+  caml_alloc_shr(size, tag)
+#define caml_alloc_shr_preserving_profinfo(size, tag, header) \
+  caml_alloc_shr(size, tag)
+#endif
 CAMLextern value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t);
 CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t);
 CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz);
@@ -49,6 +59,7 @@ CAMLextern void * caml_stat_resize (void *, asize_t);     /* Size in bytes. */
 CAMLextern int caml_init_alloc_for_heap (void);
 CAMLextern char *caml_alloc_for_heap (asize_t request);   /* Size in bytes. */
 CAMLextern void caml_free_for_heap (char *mem);
+CAMLextern void caml_disown_for_heap (char *mem);
 CAMLextern int caml_add_to_heap (char *mem);
 CAMLextern color_t caml_allocation_color (void *hp);
 
@@ -56,7 +67,7 @@ CAMLextern int caml_huge_fallback_count;
 
 /* void caml_shrink_heap (char *);        Only used in compact.c */
 
-/* <private> */
+#ifdef CAML_INTERNALS
 
 extern uintnat caml_use_huge_pages;
 
@@ -83,7 +94,8 @@ int caml_page_table_initialize(mlsize_t bytesize);
 #define DEBUG_clear(result, wosize)
 #endif
 
-#define Alloc_small(result, wosize, tag) do{    CAMLassert ((wosize) >= 1); \
+#define Alloc_small_with_profinfo(result, wosize, tag, profinfo) do {       \
+                                                CAMLassert ((wosize) >= 1); \
                                           CAMLassert ((tag_t) (tag) < 256); \
                                  CAMLassert ((wosize) <= Max_young_wosize); \
   caml_young_ptr -= Whsize_wosize (wosize);                                 \
@@ -95,16 +107,27 @@ int caml_page_table_initialize(mlsize_t bytesize);
     Restore_after_gc;                                                       \
     caml_young_ptr -= Whsize_wosize (wosize);                               \
   }                                                                         \
-  Hd_hp (caml_young_ptr) = Make_header ((wosize), (tag), Caml_black);       \
+  Hd_hp (caml_young_ptr) =                                                  \
+    Make_header_with_profinfo ((wosize), (tag), Caml_black, profinfo);      \
   (result) = Val_hp (caml_young_ptr);                                       \
   DEBUG_clear ((result), (wosize));                                         \
 }while(0)
 
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+extern uintnat caml_spacetime_my_profinfo(struct ext_table**, uintnat);
+#define Alloc_small(result, wosize, tag) \
+  Alloc_small_with_profinfo(result, wosize, tag, \
+    caml_spacetime_my_profinfo(NULL, wosize))
+#else
+#define Alloc_small(result, wosize, tag) \
+  Alloc_small_with_profinfo(result, wosize, tag, (uintnat) 0)
+#endif
+
 /* Deprecated alias for [caml_modify] */
 
 #define Modify(fp,val) caml_modify((fp), (val))
 
-/* </private> */
+#endif /* CAML_INTERNALS */
 
 struct caml__roots_block {
   struct caml__roots_block *next;
@@ -198,6 +221,7 @@ CAMLextern struct caml__roots_block *caml_local_roots;  /* defined in roots.c */
 #define CAMLxparam1(x) \
   struct caml__roots_block caml__roots_##x; \
   CAMLunused_start int caml__dummy_##x = ( \
+    (void) caml__frame, \
     (caml__roots_##x.next = caml_local_roots), \
     (caml_local_roots = &caml__roots_##x), \
     (caml__roots_##x.nitems = 1), \
@@ -209,6 +233,7 @@ CAMLextern struct caml__roots_block *caml_local_roots;  /* defined in roots.c */
 #define CAMLxparam2(x, y) \
   struct caml__roots_block caml__roots_##x; \
   CAMLunused_start int caml__dummy_##x = ( \
+    (void) caml__frame, \
     (caml__roots_##x.next = caml_local_roots), \
     (caml_local_roots = &caml__roots_##x), \
     (caml__roots_##x.nitems = 1), \
@@ -221,6 +246,7 @@ CAMLextern struct caml__roots_block *caml_local_roots;  /* defined in roots.c */
 #define CAMLxparam3(x, y, z) \
   struct caml__roots_block caml__roots_##x; \
   CAMLunused_start int caml__dummy_##x = ( \
+    (void) caml__frame, \
     (caml__roots_##x.next = caml_local_roots), \
     (caml_local_roots = &caml__roots_##x), \
     (caml__roots_##x.nitems = 1), \
@@ -234,6 +260,7 @@ CAMLextern struct caml__roots_block *caml_local_roots;  /* defined in roots.c */
 #define CAMLxparam4(x, y, z, t) \
   struct caml__roots_block caml__roots_##x; \
   CAMLunused_start int caml__dummy_##x = ( \
+    (void) caml__frame, \
     (caml__roots_##x.next = caml_local_roots), \
     (caml_local_roots = &caml__roots_##x), \
     (caml__roots_##x.nitems = 1), \
@@ -248,6 +275,7 @@ CAMLextern struct caml__roots_block *caml_local_roots;  /* defined in roots.c */
 #define CAMLxparam5(x, y, z, t, u) \
   struct caml__roots_block caml__roots_##x; \
   CAMLunused_start int caml__dummy_##x = ( \
+    (void) caml__frame, \
     (caml__roots_##x.next = caml_local_roots), \
     (caml_local_roots = &caml__roots_##x), \
     (caml__roots_##x.nitems = 1), \
@@ -263,6 +291,7 @@ CAMLextern struct caml__roots_block *caml_local_roots;  /* defined in roots.c */
 #define CAMLxparamN(x, size) \
   struct caml__roots_block caml__roots_##x; \
   CAMLunused_start int caml__dummy_##x = (     \
+    (void) caml__frame, \
     (caml__roots_##x.next = caml_local_roots), \
     (caml_local_roots = &caml__roots_##x), \
     (caml__roots_##x.nitems = (size)), \

diff --git a/byterun/caml/misc.h b/byterun/caml/misc.h
index ce3ce1619941bce3f4b2922bb1e95f377641f8ad..be7d00d47ba45d432559623804929cb978327e98 100644 (file)
--- a/byterun/caml/misc.h
+++ b/byterun/caml/misc.h
@@ -36,9 +36,9 @@ typedef size_t asize_t;
 #define NULL 0
 #endif
 
-/* <private> */
+#ifdef CAML_INTERNALS
 typedef char * addr;
-/* </private> */
+#endif /* CAML_INTERNALS */
 
 /* Noreturn is preserved for compatibility reasons.
    Instead of the legacy GCC/Clang-only
@@ -124,7 +124,101 @@ CAMLnoreturn_end;
 CAMLextern char * caml_strdup(const char * s);
 CAMLextern char * caml_strconcat(int n, ...); /* n args of const char * type */
 
-/* <private> */
+/* Use macros for some system calls being called from OCaml itself.
+  These calls can be either traced for security reasons, or changed to
+  virtualize the program. */
+
+
+#ifndef CAML_WITH_CPLUGINS
+
+#define CAML_SYS_EXIT(retcode) exit(retcode)
+#define CAML_SYS_OPEN(filename,flags,perm) open(filename,flags,perm)
+#define CAML_SYS_CLOSE(fd) close(fd)
+#define CAML_SYS_STAT(filename,st) stat(filename,st)
+#define CAML_SYS_UNLINK(filename) unlink(filename)
+#define CAML_SYS_RENAME(old_name,new_name) rename(old_name, new_name)
+#define CAML_SYS_CHDIR(dirname) chdir(dirname)
+#define CAML_SYS_GETENV(varname) getenv(varname)
+#define CAML_SYS_SYSTEM(command) system(command)
+#define CAML_SYS_READ_DIRECTORY(dirname,tbl) caml_read_directory(dirname,tbl)
+
+#else
+
+
+#define CAML_CPLUGINS_EXIT 0
+#define CAML_CPLUGINS_OPEN 1
+#define CAML_CPLUGINS_CLOSE 2
+#define CAML_CPLUGINS_STAT 3
+#define CAML_CPLUGINS_UNLINK 4
+#define CAML_CPLUGINS_RENAME 5
+#define CAML_CPLUGINS_CHDIR 6
+#define CAML_CPLUGINS_GETENV 7
+#define CAML_CPLUGINS_SYSTEM 8
+#define CAML_CPLUGINS_READ_DIRECTORY 9
+#define CAML_CPLUGINS_PRIMS_MAX 9
+
+#define CAML_CPLUGINS_PRIMS_BITMAP  ((1 << CAML_CPLUGINS_PRIMS_MAX)-1)
+
+extern intnat (*caml_cplugins_prim)(int,intnat,intnat,intnat);
+
+#define CAML_SYS_PRIM_1(code,prim,arg1)               \
+  (caml_cplugins_prim == NULL) ? prim(arg1) :    \
+  caml_cplugins_prim(code,(intnat) (arg1),0,0)
+#define CAML_SYS_STRING_PRIM_1(code,prim,arg1)               \
+  (caml_cplugins_prim == NULL) ? prim(arg1) :    \
+  (char*)caml_cplugins_prim(code,(intnat) (arg1),0,0)
+#define CAML_SYS_PRIM_2(code,prim,arg1,arg2)                         \
+  (caml_cplugins_prim == NULL) ? prim(arg1,arg2) :              \
+  caml_cplugins_prim(code,(intnat) (arg1), (intnat) (arg2),0)
+#define CAML_SYS_PRIM_3(code,prim,arg1,arg2,arg3)                            \
+  (caml_cplugins_prim == NULL) ? prim(arg1,arg2,arg3) :                 \
+  caml_cplugins_prim(code,(intnat) (arg1), (intnat) (arg2),(intnat) (arg3))
+
+#define CAML_SYS_EXIT(retcode) \
+  CAML_SYS_PRIM_1(CAML_CPLUGINS_EXIT,exit,retcode)
+#define CAML_SYS_OPEN(filename,flags,perm)                      \
+  CAML_SYS_PRIM_3(CAML_CPLUGINS_OPEN,open,filename,flags,perm)
+#define CAML_SYS_CLOSE(fd)                      \
+  CAML_SYS_PRIM_1(CAML_CPLUGINS_CLOSE,close,fd)
+#define CAML_SYS_STAT(filename,st)                      \
+  CAML_SYS_PRIM_2(CAML_CPLUGINS_STAT,stat,filename,st)
+#define CAML_SYS_UNLINK(filename)                       \
+  CAML_SYS_PRIM_1(CAML_CPLUGINS_UNLINK,unlink,filename)
+#define CAML_SYS_RENAME(old_name,new_name)                              \
+  CAML_SYS_PRIM_2(CAML_CPLUGINS_RENAME,rename,old_name,new_name)
+#define CAML_SYS_CHDIR(dirname)                         \
+  CAML_SYS_PRIM_1(CAML_CPLUGINS_CHDIR,chdir,dirname)
+#define CAML_SYS_GETENV(varname)                        \
+  CAML_SYS_STRING_PRIM_1(CAML_CPLUGINS_GETENV,getenv,varname)
+#define CAML_SYS_SYSTEM(command)                        \
+  CAML_SYS_PRIM_1(CAML_CPLUGINS_SYSTEM,system,command)
+#define CAML_SYS_READ_DIRECTORY(dirname,tbl)                            \
+  CAML_SYS_PRIM_2(CAML_CPLUGINS_READ_DIRECTORY,caml_read_directory,     \
+                  dirname,tbl)
+
+#define CAML_CPLUGIN_CONTEXT_API 0
+
+struct cplugin_context {
+  int api_version;
+  int prims_bitmap;
+  char *exe_name;
+  char** argv;
+  char *plugin; /* absolute filename of plugin, do a copy if you need it ! */
+  char *ocaml_version;
+/* end of CAML_CPLUGIN_CONTEXT_API version 0 */
+};
+
+extern void caml_cplugins_init(char * exe_name, char **argv);
+
+/* A plugin MUST define a symbol "caml_cplugin_init" with the prototype:
+
+void caml_cplugin_init(struct cplugin_context *ctx)
+*/
+
+/* to write plugins for CAML_SYS_READ_DIRECTORY, we will need the
+   definition of struct ext_table to be public. */
+
+#endif /* CAML_WITH_CPLUGINS */
 
 /* Data structures */
 
@@ -138,6 +232,12 @@ extern void caml_ext_table_init(struct ext_table * tbl, int init_capa);
 extern int caml_ext_table_add(struct ext_table * tbl, void * data);
 extern void caml_ext_table_remove(struct ext_table * tbl, void * data);
 extern void caml_ext_table_free(struct ext_table * tbl, int free_entries);
+extern void caml_ext_table_clear(struct ext_table * tbl, int free_entries);
+
+CAMLextern int caml_read_directory(char * dirname, struct ext_table * contents);
+
+
+#ifdef CAML_INTERNALS
 
 /* GC flags and messages */
 
@@ -301,7 +401,7 @@ extern void CAML_INSTR_ATEXIT (void);
 
 #endif /* CAML_INSTR */
 
-/* </private> */
+#endif /* CAML_INTERNALS */
 
 #ifdef __cplusplus
 }

diff --git a/byterun/caml/mlvalues.h b/byterun/caml/mlvalues.h
index 057914330d9444cd78ab37949228c80dacdbd00c..c4d31b991ce995e19b60fdb1e47eb17f8f0f94f7 100644 (file)
--- a/byterun/caml/mlvalues.h
+++ b/byterun/caml/mlvalues.h
@@ -94,10 +94,33 @@ For 64-bit architectures:
      +--------+-------+-----+
 bits  63    10 9     8 7   0
 
+For x86-64 with Spacetime profiling:
+  P = PROFINFO_WIDTH (as set by "configure", currently 26 bits, giving a
+    maximum block size of just under 4Gb)
+     +----------------+----------------+-------------+
+     | profiling info | wosize         | color | tag |
+     +----------------+----------------+-------------+
+bits  63        (64-P) (63-P)        10 9     8 7   0
+
 */
 
+#define PROFINFO_SHIFT (64 - PROFINFO_WIDTH)
+#define PROFINFO_MASK ((1ull << PROFINFO_WIDTH) - 1ull)
+
 #define Tag_hd(hd) ((tag_t) ((hd) & 0xFF))
+#ifdef WITH_SPACETIME
+#define Hd_no_profinfo(hd) ((hd) & ~(PROFINFO_MASK << PROFINFO_SHIFT))
+#define Wosize_hd(hd) ((mlsize_t) ((Hd_no_profinfo(hd)) >> 10))
+#else
 #define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10))
+#endif /* SPACETIME */
+#ifdef ARCH_SIXTYFOUR
+/* [Profinfo_hd] is used when the compiler is not configured for Spacetime
+   (e.g. when decoding profiles). */
+#define Profinfo_hd(hd) (((mlsize_t) ((hd) >> PROFINFO_SHIFT)) & PROFINFO_MASK)
+#else
+#define Profinfo_hd(hd) ((hd) & 0)
+#endif /* ARCH_SIXTYFOUR */
 
 #define Hd_val(val) (((header_t *) (val)) [-1])        /* Also an l-value. */
 #define Hd_op(op) (Hd_val (op))                        /* Also an l-value. */
@@ -113,7 +136,11 @@ bits  63    10 9     8 7   0
 
 #define Num_tags (1 << 8)
 #ifdef ARCH_SIXTYFOUR
+#ifdef WITH_SPACETIME
+#define Max_wosize (((intnat)1 << (54-PROFINFO_WIDTH)) - 1)
+#else
 #define Max_wosize (((intnat)1 << 54) - 1)
+#endif
 #else
 #define Max_wosize ((1 << 22) - 1)
 #endif
@@ -140,6 +167,8 @@ bits  63    10 9     8 7   0
 #define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp)))
 #define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd)))
 
+#define Profinfo_val(val) (Profinfo_hd (Hd_val (val)))
+
 #ifdef ARCH_BIG_ENDIAN
 #define Tag_val(val) (((unsigned char *) (val)) [-1])
                                                  /* Also an l-value. */

diff --git a/byterun/caml/osdeps.h b/byterun/caml/osdeps.h
index 71c2197ede1da20b8e769444e49a6bad9de9558d..7fcf903a62a0d19b7e9a5cd4a93a2611e249b9f0 100644 (file)
--- a/byterun/caml/osdeps.h
+++ b/byterun/caml/osdeps.h
@@ -18,6 +18,8 @@
 #ifndef CAML_OSDEPS_H
 #define CAML_OSDEPS_H
 
+#ifdef CAML_INTERNALS
+
 #include "misc.h"
 
 /* Read at most [n] bytes from file descriptor [fd] into buffer [buf].
@@ -83,4 +85,6 @@ extern int caml_read_directory(char * dirname, struct ext_table * contents);
    GetModuleFileName under Windows). */
 extern int caml_executable_name(char * name, int name_len);
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_OSDEPS_H */

diff --git a/byterun/caml/prims.h b/byterun/caml/prims.h
index 5fdf29f236915f847ea3dc0520497567c0a7d049..147cd98a60a5ba419a4ae2c1aa9ed73615be298d 100644 (file)
--- a/byterun/caml/prims.h
+++ b/byterun/caml/prims.h
@@ -18,6 +18,8 @@
 #ifndef CAML_PRIMS_H
 #define CAML_PRIMS_H
 
+#ifdef CAML_INTERNALS
+
 typedef value (*c_primitive)();
 
 extern c_primitive caml_builtin_cprim[];
@@ -33,4 +35,6 @@ extern struct ext_table caml_prim_name_table;
 extern char * caml_section_table;
 extern asize_t caml_section_table_size;
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_PRIMS_H */

diff --git a/byterun/caml/reverse.h b/byterun/caml/reverse.h
index c1134356a0ff7ae6906f74081b06df7146d09b9c..a186078e1a3ae6cd1d59b5eb0754e7a5d3718cd1 100644 (file)
--- a/byterun/caml/reverse.h
+++ b/byterun/caml/reverse.h
@@ -18,6 +18,8 @@
 #ifndef CAML_REVERSE_H
 #define CAML_REVERSE_H
 
+#ifdef CAML_INTERNALS
+
 #define Reverse_16(dst,src) {                                               \
   char * _p, * _q;                                                          \
   char _a;                                                                  \
@@ -85,4 +87,6 @@
   _p[Perm_index(perm_dst, 7)] = _h;                                         \
 }
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_REVERSE_H */

diff --git a/byterun/caml/roots.h b/byterun/caml/roots.h
index f8440bec7db16c5d185f888d8db7949b2bb3e050..fed345d303df4b52075063522937d34717bfde40 100644 (file)
--- a/byterun/caml/roots.h
+++ b/byterun/caml/roots.h
@@ -16,6 +16,8 @@
 #ifndef CAML_ROOTS_H
 #define CAML_ROOTS_H
 
+#ifdef CAML_INTERNALS
+
 #include "misc.h"
 #include "memory.h"
 
@@ -37,4 +39,6 @@ CAMLextern void caml_do_local_roots(scanning_action f, char * bottom_of_stack,
 
 CAMLextern void (*caml_scan_roots_hook) (scanning_action);
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_ROOTS_H */

diff --git a/byterun/caml/signals.h b/byterun/caml/signals.h
index ce968251b4795e11e05e2897efd56f7bcc03bda0..99924e4f5c406edafe53e0d4f4f6c2339323cc45 100644 (file)
--- a/byterun/caml/signals.h
+++ b/byterun/caml/signals.h
@@ -26,18 +26,13 @@
 extern "C" {
 #endif
 
-/* <private> */
+#ifdef CAML_INTERNALS
 CAMLextern intnat volatile caml_signals_are_pending;
 CAMLextern intnat volatile caml_pending_signals[];
 CAMLextern int volatile caml_something_to_do;
 extern int volatile caml_requested_major_slice;
 extern int volatile caml_requested_minor_gc;
-/* </private> */
 
-CAMLextern void caml_enter_blocking_section (void);
-CAMLextern void caml_leave_blocking_section (void);
-
-/* <private> */
 void caml_request_major_slice (void);
 void caml_request_minor_gc (void);
 CAMLextern int caml_convert_signal_number (int);
@@ -52,7 +47,10 @@ CAMLextern void (*caml_enter_blocking_section_hook)(void);
 CAMLextern void (*caml_leave_blocking_section_hook)(void);
 CAMLextern int (*caml_try_leave_blocking_section_hook)(void);
 CAMLextern void (* volatile caml_async_action_hook)(void);
-/* </private> */
+#endif /* CAML_INTERNALS */
+
+CAMLextern void caml_enter_blocking_section (void);
+CAMLextern void caml_leave_blocking_section (void);
 
 #ifdef __cplusplus
 }

diff --git a/byterun/caml/signals_machdep.h b/byterun/caml/signals_machdep.h
index 6dd2cbc0d9a36aaf8fa5c564a8bf540a39fbb52b..ef4e5bbd42315b57e38688d5eb194b5c11ca8b1b 100644 (file)
--- a/byterun/caml/signals_machdep.h
+++ b/byterun/caml/signals_machdep.h
@@ -18,6 +18,8 @@
 #ifndef CAML_SIGNALS_MACHDEP_H
 #define CAML_SIGNALS_MACHDEP_H
 
+#ifdef CAML_INTERNALS
+
 #if defined(__GNUC__) && defined(__ATOMIC_SEQ_CST) \
     && defined(__GCC_ATOMIC_LONG_LOCK_FREE)
 
@@ -67,4 +69,6 @@
 
 #endif
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_SIGNALS_MACHDEP_H */

diff --git a/byterun/caml/stack.h b/byterun/caml/stack.h
new file mode 100644 (file)
index 0000000..fd9d528
--- /dev/null
+++ b/byterun/caml/stack.h
@@ -0,0 +1,129 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1996 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Machine-dependent interface with the asm code */
+
+#ifndef CAML_STACK_H
+#define CAML_STACK_H
+
+#ifdef CAML_INTERNALS
+
+/* Macros to access the stack frame */
+
+#ifdef TARGET_sparc
+#define Saved_return_address(sp) *((intnat *)((sp) + 92))
+#define Callback_link(sp) ((struct caml_context *)((sp) + 104))
+#endif
+
+#ifdef TARGET_i386
+#define Saved_return_address(sp) *((intnat *)((sp) - 4))
+#ifndef SYS_win32
+#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
+#else
+#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
+#endif
+#endif
+
+#ifdef TARGET_power
+#if defined(MODEL_ppc)
+#define Saved_return_address(sp) *((intnat *)((sp) - 4))
+#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
+#elif defined(MODEL_ppc64)
+#define Saved_return_address(sp) *((intnat *)((sp) + 16))
+#define Callback_link(sp) ((struct caml_context *)((sp) + (48 + 32)))
+#elif defined(MODEL_ppc64le)
+#define Saved_return_address(sp) *((intnat *)((sp) + 16))
+#define Callback_link(sp) ((struct caml_context *)((sp) + (32 + 32)))
+#else
+#error "TARGET_power: wrong MODEL"
+#endif
+#define Already_scanned(sp, retaddr) ((retaddr) & 1)
+#define Mask_already_scanned(retaddr) ((retaddr) & ~1)
+#define Mark_scanned(sp, retaddr) Saved_return_address(sp) = (retaddr) | 1
+#endif
+
+#ifdef TARGET_s390x
+#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR))
+#define Trap_frame_size 16
+#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size))
+#endif
+
+#ifdef TARGET_arm
+#define Saved_return_address(sp) *((intnat *)((sp) - 4))
+#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
+#endif
+
+#ifdef TARGET_amd64
+#define Saved_return_address(sp) *((intnat *)((sp) - 8))
+#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
+#endif
+
+#ifdef TARGET_arm64
+#define Saved_return_address(sp) *((intnat *)((sp) - 8))
+#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
+#endif
+
+/* Structure of OCaml callback contexts */
+
+struct caml_context {
+  char * bottom_of_stack;       /* beginning of OCaml stack chunk */
+  uintnat last_retaddr;         /* last return address in OCaml code */
+  value * gc_regs;              /* pointer to register block */
+#ifdef WITH_SPACETIME
+  void* trie_node;
+#endif
+};
+
+/* Structure of frame descriptors */
+
+typedef struct {
+  uintnat retaddr;
+  unsigned short frame_size;
+  unsigned short num_live;
+  unsigned short live_ofs[1];
+} frame_descr;
+
+/* Hash table of frame descriptors */
+
+extern frame_descr ** caml_frame_descriptors;
+extern int caml_frame_descriptors_mask;
+
+#define Hash_retaddr(addr) \
+  (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask)
+
+extern void caml_init_frame_descriptors(void);
+extern void caml_register_frametable(intnat *);
+extern void caml_unregister_frametable(intnat *);
+extern void caml_register_dyn_global(void *);
+
+extern uintnat caml_stack_usage (void);
+extern uintnat (*caml_stack_usage_hook)(void);
+
+/* Declaration of variables used in the asm code */
+extern char * caml_top_of_stack;
+extern char * caml_bottom_of_stack;
+extern uintnat caml_last_return_address;
+extern value * caml_gc_regs;
+extern char * caml_exception_pointer;
+extern value * caml_globals[];
+extern char caml_globals_map[];
+extern intnat caml_globals_inited;
+extern intnat * caml_frametable[];
+
+CAMLextern frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp);
+
+#endif /* CAML_INTERNALS */
+
+#endif /* CAML_STACK_H */

diff --git a/byterun/caml/stacks.h b/byterun/caml/stacks.h
index 9a0f634b546447a453ad36fc8f742fbd51956dac..18ec0ac306bb8066a3b6b47ccd16396bfba92c73 100644 (file)
--- a/byterun/caml/stacks.h
+++ b/byterun/caml/stacks.h
@@ -18,6 +18,7 @@
 #ifndef CAML_STACKS_H
 #define CAML_STACKS_H
 
+#ifdef CAML_INTERNALS
 
 #include "misc.h"
 #include "mlvalues.h"
@@ -40,4 +41,6 @@ uintnat caml_stack_usage (void);
 
 CAMLextern uintnat (*caml_stack_usage_hook)(void);
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_STACKS_H */

diff --git a/byterun/caml/startup.h b/byterun/caml/startup.h
index 2cf111a606e8f5e41f5af929fd8aacd655d5ab81..3df4206aa4a6459677a23f6f659927f22f3f8db5 100644 (file)
--- a/byterun/caml/startup.h
+++ b/byterun/caml/startup.h
@@ -16,6 +16,8 @@
 #ifndef CAML_STARTUP_H
 #define CAML_STARTUP_H
 
+#ifdef CAML_INTERNALS
+
 #include "mlvalues.h"
 #include "exec.h"
 
@@ -37,5 +39,6 @@ extern int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail,
 extern int32_t caml_seek_section(int fd, struct exec_trailer *trail,
                                  char *name);
 
+#endif /* CAML_INTERNALS */
 
 #endif /* CAML_STARTUP_H */

diff --git a/byterun/caml/startup_aux.h b/byterun/caml/startup_aux.h
index faa7b7eecfa11424d366fda37a465071983820aa..203a47d73d17f5c244bcf7c429fedaee2d68d450 100644 (file)
--- a/byterun/caml/startup_aux.h
+++ b/byterun/caml/startup_aux.h
@@ -13,6 +13,11 @@
 /*                                                                        */
 /**************************************************************************/
 
+#ifndef CAML_STARTUP_AUX_H
+#define CAML_STARTUP_AUX_H
+
+#ifdef CAML_INTERNALS
+
 #include "config.h"
 
 extern void caml_init_atom_table (void);
@@ -27,3 +32,7 @@ extern uintnat caml_init_major_window;
 extern uintnat caml_trace_level;
 
 extern void caml_parse_ocamlrunparam (void);
+
+#endif /* CAML_INTERNALS */
+
+#endif /* CAML_STARTUP_AUX_H */

diff --git a/byterun/caml/sys.h b/byterun/caml/sys.h
index 79ef3ddba4f4ada110ede10091c9041420e419d7..e31e3cef9f18683258d2fa226f5499bf05f56981 100644 (file)
--- a/byterun/caml/sys.h
+++ b/byterun/caml/sys.h
@@ -16,15 +16,30 @@
 #ifndef CAML_SYS_H
 #define CAML_SYS_H
 
+#ifdef CAML_INTERNALS
+
 #include "misc.h"
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 #define NO_ARG Val_int(0)
 
 CAMLextern void caml_sys_error (value);
 CAMLextern void caml_sys_io_error (value);
-extern void caml_sys_init (char * exe_name, char ** argv);
+CAMLextern double caml_sys_time_unboxed(value);
+CAMLextern void caml_sys_init (char * exe_name, char ** argv);
 CAMLextern value caml_sys_exit (value);
+extern double caml_sys_time_unboxed(value);
+CAMLextern value caml_sys_get_argv(value unit);
 
 extern char * caml_exe_name;
 
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_SYS_H */

diff --git a/byterun/caml/ui.h b/byterun/caml/ui.h
index 9551ff4853e68e09119143ef16382038bc7857ed..3047ba7fb75d3134b32cd8208d6c90f416c1e25d 100644 (file)
--- a/byterun/caml/ui.h
+++ b/byterun/caml/ui.h
@@ -18,6 +18,8 @@
 #ifndef CAML_UI_H
 #define CAML_UI_H
 
+#ifdef CAML_INTERNALS
+
 #include "config.h"
 
 void ui_exit (int return_code);
@@ -25,4 +27,6 @@ int ui_read (int file_desc, char *buf, unsigned int length);
 int ui_write (int file_desc, char *buf, unsigned int length);
 void ui_print_stderr (char *format, void *arg);
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_UI_H */

diff --git a/byterun/caml/weak.h b/byterun/caml/weak.h
index 5cfc8133b2419445cc8d577c32c209ec169da787..a716d2122f09ba3d25749916b1cf5c0a973f9ebb 100644 (file)
--- a/byterun/caml/weak.h
+++ b/byterun/caml/weak.h
@@ -18,6 +18,8 @@
 #ifndef CAML_WEAK_H
 #define CAML_WEAK_H
 
+#ifdef CAML_INTERNALS
+
 #include "mlvalues.h"
 
 extern value caml_ephe_list_head;
@@ -86,4 +88,6 @@ static inline void caml_ephe_clean (value v){
   }
 }
 
+#endif /* CAML_INTERNALS */
+
 #endif /* CAML_WEAK_H */

diff --git a/byterun/compact.c b/byterun/compact.c
index f9f604b23a58ac77b011a3552719425177b6db8b..cd46623ad0417898b45b999249ccef905098b5e5 100644 (file)
--- a/byterun/compact.c
+++ b/byterun/compact.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <string.h>
 
 #include "caml/address_class.h"
@@ -26,6 +28,7 @@
 #include "caml/mlvalues.h"
 #include "caml/roots.h"
 #include "caml/weak.h"
+#include "caml/compact.h"
 
 extern uintnat caml_percent_free;                   /* major_gc.c */
 extern void caml_shrink_heap (char *);              /* memory.c */
@@ -46,10 +49,16 @@ extern void caml_shrink_heap (char *);              /* memory.c */
   XXX (see [caml_register_global_roots])
   XXX Should be able to fix it to only assume 2-byte alignment.
 */
-#define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c))
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#define Make_ehd(s,t,c,p) \
+  (((s) << 10) | (t) << 2 | (c) | ((p) << PROFINFO_SHIFT))
+#else
+#define Make_ehd(s,t,c,p) (((s) << 10) | (t) << 2 | (c))
+#endif
 #define Whsize_ehd(h) Whsize_hd (h)
 #define Wosize_ehd(h) Wosize_hd (h)
 #define Tag_ehd(h) (((h) >> 2) & 0xFF)
+#define Profinfo_ehd(hd) Profinfo_hd(hd)
 #define Ecolor(w) ((w) & 3)
 
 typedef uintnat word;
@@ -88,7 +97,7 @@ static void invert_pointer_at (word *p)
           Hd_val (q) = (header_t) ((word) p | 2);
           /* Change block header's tag to Infix_tag, and change its size
              to point to the infix list. */
-          *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3);
+          *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0);
         }else{                            Assert (Tag_ehd (*hp) == Infix_tag);
           /* Point the last of this infix list to the current first infix
              list of the block. */
@@ -96,7 +105,7 @@ static void invert_pointer_at (word *p)
           /* Point the head of this infix list to the above. */
           Hd_val (q) = (header_t) ((word) p | 2);
           /* Change block header's size to point to this infix list. */
-          *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3);
+          *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0);
         }
       }
       break;
@@ -108,7 +117,7 @@ static void invert_pointer_at (word *p)
   }
 }
 
-static void invert_root (value v, value *p)
+void invert_root (value v, value *p)
 {
   invert_pointer_at ((word *) p);
 }
@@ -168,10 +177,10 @@ static void do_compaction (void)
 
         if (Is_blue_hd (hd)){
           /* Free object.  Give it a string tag. */
-          Hd_hp (p) = Make_ehd (sz, String_tag, 3);
+          Hd_hp (p) = Make_ehd (sz, String_tag, 3, (uintnat) 0);
         }else{                                      Assert (Is_white_hd (hd));
           /* Live object.  Keep its tag. */
-          Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3);
+          Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3, Profinfo_hd (hd));
         }
         p += Whsize_wosize (sz);
       }
@@ -188,7 +197,8 @@ static void do_compaction (void)
        data structures to find its roots.  Fortunately, it doesn't need
        the headers (see above). */
     caml_do_roots (invert_root, 1);
-    caml_final_do_weak_roots (invert_root);
+    /* The values to be finalised are not roots but should still be inverted */
+    caml_final_invert_finalisable_values ();
 
     ch = caml_heap_start;
     while (ch != NULL){
@@ -263,11 +273,13 @@ static void do_compaction (void)
           size_t sz;
           tag_t t;
           char *newadr;
+          uintnat profinfo;
           word *infixes = NULL;
 
           while (Ecolor (q) == 0) q = * (word *) q;
           sz = Whsize_ehd (q);
           t = Tag_ehd (q);
+          profinfo = Profinfo_ehd (q);
 
           if (t == Infix_tag){
             /* Get the original header of this block. */
@@ -285,7 +297,8 @@ static void do_compaction (void)
             * (word *) q = (word) Val_hp (newadr);
             q = next;
           }
-          *p = Make_header (Wosize_whsize (sz), t, Caml_white);
+          *p = Make_header_with_profinfo (Wosize_whsize (sz), t, Caml_white,
+            profinfo);
 
           if (infixes != NULL){
             /* Rebuild the infix headers and revert the infix pointers. */
@@ -299,6 +312,9 @@ static void do_compaction (void)
                 * (word *) q = (word) Val_hp ((word *) newadr + (infixes - p));
                 q = next;
               }                    Assert (Ecolor (q) == 1 || Ecolor (q) == 3);
+              /* No need to preserve any profinfo value on the [Infix_tag]
+                 headers; the Spacetime profiling heap snapshot code doesn't
+                 look at them. */
               *infixes = Make_header (infixes - p, Infix_tag, Caml_white);
               infixes = (word *) q;
             }
@@ -511,6 +527,9 @@ void caml_compact_heap_maybe (void)
   caml_gc_message (0x200, "FL size at phase change = %"
                           ARCH_INTNAT_PRINTF_FORMAT "u words\n",
                    (uintnat) caml_fl_wsz_at_phase_change);
+  caml_gc_message (0x200, "FL current size = %"
+                          ARCH_INTNAT_PRINTF_FORMAT "u words\n",
+                   (uintnat) caml_fl_cur_wsz);
   caml_gc_message (0x200, "Estimated overhead = %"
                           ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                    (uintnat) fp);
@@ -524,7 +543,10 @@ void caml_compact_heap_maybe (void)
     caml_gc_message (0x200, "Measured overhead: %"
                             ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                      (uintnat) fp);
+    if (fp >= caml_percent_max)
+         caml_compact_heap ();
+    else
+         caml_gc_message (0x200, "Automatic compaction aborted.\n", 0);
 
-    caml_compact_heap ();
   }
 }

diff --git a/byterun/compare.c b/byterun/compare.c
index 42384a47a60778bd121abb668f1b20842d3a64e5..f34accd798225344cfeeccc3b49747eabd236166 100644 (file)
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <string.h>
 #include <stdlib.h>
 #include "caml/custom.h"
@@ -21,6 +23,10 @@
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 
+#if defined(LACKS_SANE_NAN) && !defined(isnan)
+#define isnan _isnan
+#endif
+
 /* Structural comparison on trees. */
 
 struct compare_item { value * v1, * v2; mlsize_t count; };
@@ -174,8 +180,19 @@ static intnat compare_val(value v1, value v2, int total)
     case Double_tag: {
       double d1 = Double_val(v1);
       double d2 = Double_val(v2);
+#ifdef LACKS_SANE_NAN
+      if (isnan(d2)) {
+        if (! total) return UNORDERED;
+        if (isnan(d1)) break;
+        return GREATER;
+      } else if (isnan(d1)) {
+        if (! total) return UNORDERED;
+        return LESS;
+      }
+#endif
       if (d1 < d2) return LESS;
       if (d1 > d2) return GREATER;
+#ifndef LACKS_SANE_NAN
       if (d1 != d2) {
         if (! total) return UNORDERED;
         /* One or both of d1 and d2 is NaN.  Order according to the
@@ -184,6 +201,7 @@ static intnat compare_val(value v1, value v2, int total)
         if (d2 == d2) return LESS;    /* d2 is not NaN, d1 is NaN */
         /* d1 and d2 are both NaN, thus equal: continue comparison */
       }
+#endif
       break;
     }
     case Double_array_tag: {
@@ -194,14 +212,26 @@ static intnat compare_val(value v1, value v2, int total)
       for (i = 0; i < sz1; i++) {
         double d1 = Double_field(v1, i);
         double d2 = Double_field(v2, i);
+#ifdef LACKS_SANE_NAN
+        if (isnan(d2)) {
+          if (! total) return UNORDERED;
+          if (isnan(d1)) break;
+          return GREATER;
+        } else if (isnan(d1)) {
+          if (! total) return UNORDERED;
+          return LESS;
+        }
+#endif
         if (d1 < d2) return LESS;
         if (d1 > d2) return GREATER;
+#ifndef LACKS_SANE_NAN
         if (d1 != d2) {
           if (! total) return UNORDERED;
           /* See comment for Double_tag case */
           if (d1 == d1) return GREATER;
           if (d2 == d2) return LESS;
         }
+#endif
       }
       break;
     }

diff --git a/byterun/custom.c b/byterun/custom.c
index 3875a4e5ec1b4f75765410d3854543ed66b99b26..2198d62d798f264f7a45d6e4a9022ad075ad0207 100644 (file)
--- a/byterun/custom.c
+++ b/byterun/custom.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <string.h>
 
 #include "caml/alloc.h"

diff --git a/byterun/debugger.c b/byterun/debugger.c
index 5e61584b2866267b25393e3936f7c95a51df2d4c..2edbaa0c58d8aa9904c3729c20950e11b3d03344 100644 (file)
--- a/byterun/debugger.c
+++ b/byterun/debugger.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Interface with the byte-code debugger */
 
 #ifdef _WIN32
@@ -220,7 +222,7 @@ void caml_debugger_init(void)
 static value getval(struct channel *chan)
 {
   value res;
-  if (caml_really_getblock(chan, (char *) &res, sizeof(res)) == 0)
+  if (caml_really_getblock(chan, (char *) &res, sizeof(res)) < sizeof(res))
     caml_raise_end_of_file(); /* Bad, but consistent with caml_getword */
   return res;
 }
@@ -267,19 +269,19 @@ void caml_debugger(enum event_kind event)
   case PROGRAM_START:           /* Nothing to report */
     goto command_loop;
   case EVENT_COUNT:
-    putch(dbg_out, REP_EVENT);
+    caml_putch(dbg_out, REP_EVENT);
     break;
   case BREAKPOINT:
-    putch(dbg_out, REP_BREAKPOINT);
+    caml_putch(dbg_out, REP_BREAKPOINT);
     break;
   case PROGRAM_EXIT:
-    putch(dbg_out, REP_EXITED);
+    caml_putch(dbg_out, REP_EXITED);
     break;
   case TRAP_BARRIER:
-    putch(dbg_out, REP_TRAP);
+    caml_putch(dbg_out, REP_TRAP);
     break;
   case UNCAUGHT_EXC:
-    putch(dbg_out, REP_UNCAUGHT_EXC);
+    caml_putch(dbg_out, REP_UNCAUGHT_EXC);
     break;
   }
   caml_putword(dbg_out, caml_event_count);
@@ -297,7 +299,7 @@ void caml_debugger(enum event_kind event)
 
   /* Read and execute the commands sent by the debugger */
   while(1) {
-    switch(getch(dbg_in)) {
+    switch(caml_getch(dbg_in)) {
     case REQ_SET_EVENT:
       pos = caml_getword(dbg_in);
       Assert (pos >= 0);
@@ -405,11 +407,11 @@ void caml_debugger(enum event_kind event)
       val = getval(dbg_in);
       i = caml_getword(dbg_in);
       if (Tag_val(val) != Double_array_tag) {
-        putch(dbg_out, 0);
+        caml_putch(dbg_out, 0);
         putval(dbg_out, Field(val, i));
       } else {
         double d = Double_field(val, i);
-        putch(dbg_out, 1);
+        caml_putch(dbg_out, 1);
         caml_really_putblock(dbg_out, (char *) &d, 8);
       }
       caml_flush(dbg_out);

diff --git a/byterun/dynlink.c b/byterun/dynlink.c
index 7142769c99f48dcb5dc8f9eff45dbe872ff6d383..f80d1f7fc7ccdb311dc0f7aca60f80bacec6d205 100644 (file)
--- a/byterun/dynlink.c
+++ b/byterun/dynlink.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Dynamic loading of C primitives. */
 
 #include <stddef.h>

diff --git a/byterun/extern.c b/byterun/extern.c
index 221e206df36ef38e1ea37c750c6c7be0c7a29ecd..eca115d8fdc1b1fa86d517cb75edd71affb69d56 100644 (file)
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Structured output */
 
 /* The interface of this file is "caml/intext.h" */
@@ -94,7 +96,6 @@ CAMLnoreturn_start
 static void extern_stack_overflow(void)
 CAMLnoreturn_end;
 
-static struct code_fragment * extern_find_code(char *addr);
 static void extern_replay_trail(void);
 static void free_extern_output(void);
 
@@ -383,6 +384,8 @@ static void writecode64(int code, intnat val)
 
 /* Marshal the given value in the output buffer */
 
+int caml_extern_allow_out_of_heap = 0;
+
 static void extern_rec(value v)
 {
   struct code_fragment * cf;
@@ -409,7 +412,7 @@ static void extern_rec(value v)
       writecode32(CODE_INT32, n);
     goto next_item;
   }
-  if (Is_in_value_area(v)) {
+  if (Is_in_value_area(v) || caml_extern_allow_out_of_heap) {
     header_t hd = Hd_val(v);
     tag_t tag = Tag_hd(hd);
     mlsize_t sz = Wosize_hd(hd);
@@ -431,7 +434,11 @@ static void extern_rec(value v)
       if (tag < 16) {
         write(PREFIX_SMALL_BLOCK + tag);
       } else {
+#if !(defined(NATIVE_CODE) && defined(WITH_SPACETIME))
         writecode32(CODE_BLOCK32, hd);
+#else
+        writecode32(CODE_BLOCK32, Hd_no_profinfo(hd));
+#endif
       }
       goto next_item;
     }
@@ -544,13 +551,18 @@ static void extern_rec(value v)
         write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
       } else {
 #ifdef ARCH_SIXTYFOUR
+#if !(defined(NATIVE_CODE) && defined(WITH_SPACETIME))
+        header_t hd_erased = hd;
+#else
+        header_t hd_erased = Hd_no_profinfo(hd);
+#endif
         if (sz > 0x3FFFFF && (extern_flags & COMPAT_32))
           extern_failwith("output_value: array cannot be read back on "
                           "32-bit platform");
-        if (hd < (uintnat)1 << 32)
-          writecode32(CODE_BLOCK32, Whitehd_hd (hd));
+        if (hd_erased < (uintnat)1 << 32)
+          writecode32(CODE_BLOCK32, Whitehd_hd (hd_erased));
         else
-          writecode64(CODE_BLOCK64, Whitehd_hd (hd));
+          writecode64(CODE_BLOCK64, Whitehd_hd (hd_erased));
 #else
         writecode32(CODE_BLOCK32, Whitehd_hd (hd));
 #endif
@@ -572,7 +584,7 @@ static void extern_rec(value v)
     }
     }
   }
-  else if ((cf = extern_find_code((char *) v)) != NULL) {
+  else if ((cf = caml_extern_find_code((char *) v)) != NULL) {
     if ((extern_flags & CLOSURES) == 0)
       extern_invalid_argument("output_value: functional value");
     writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
@@ -889,7 +901,7 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len)
 
 /* Find where a code pointer comes from */
 
-static struct code_fragment * extern_find_code(char *addr)
+CAMLexport struct code_fragment * caml_extern_find_code(char *addr)
 {
   int i;
   for (i = caml_code_fragments_table.size - 1; i >= 0; i--) {

diff --git a/byterun/fail.c b/byterun/fail.c
index 8ba6c76730699806785e4029599b01a1845efed0..80eca18a7ba160f40b4ed9751ca7301ee91e3eaf 100644 (file)
--- a/byterun/fail.c
+++ b/byterun/fail.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Raising exceptions from C. */
 
 #include <stdio.h>

diff --git a/byterun/finalise.c b/byterun/finalise.c
index 9c707c1d883287813ee215e8b7d2c074f1e96dc2..91088cf1f20ac205cf91405c61331320db1ce79f 100644 (file)
--- a/byterun/finalise.c
+++ b/byterun/finalise.c
@@ -13,13 +13,21 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Handling of finalised values. */
 
 #include "caml/callback.h"
+#include "caml/compact.h"
 #include "caml/fail.h"
+#include "caml/finalise.h"
+#include "caml/minor_gc.h"
 #include "caml/mlvalues.h"
 #include "caml/roots.h"
 #include "caml/signals.h"
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#include "../asmrun/spacetime.h"
+#endif
 
 struct final {
   value fun;
@@ -27,13 +35,24 @@ struct final {
   int offset;
 };
 
-static struct final *final_table = NULL;
-static uintnat old = 0, young = 0, size = 0;
-/* [0..old) : finalisable set
-   [old..young) : recent set
+struct finalisable {
+  struct final *table;
+  uintnat old;
+  uintnat young;
+  uintnat size;
+};
+/* [0..old) : finalisable set, the values are in the major heap
+   [old..young) : recent set, the values could be in the minor heap
    [young..size) : free space
+
+   The element of the finalisable set are moved to the finalising set
+   below when the value are unreachable (for the first or last time).
+
 */
 
+static struct finalisable finalisable_first = {NULL,0,0,0};
+static struct finalisable finalisable_last = {NULL,0,0,0};
+
 struct to_do {
   struct to_do *next;
   int size;
@@ -42,6 +61,13 @@ struct to_do {
 
 static struct to_do *to_do_hd = NULL;
 static struct to_do *to_do_tl = NULL;
+/*
+  to_do_hd: head of the list of finalisation functions that can be run.
+  to_do_tl: tail of the list of finalisation functions that can be run.
+
+  It is the finalising set.
+*/
+
 
 /* [size] is a number of elements for the [to_do.item] array */
 static void alloc_to_do (int size)
@@ -62,48 +88,80 @@ static void alloc_to_do (int size)
 }
 
 /* Find white finalisable values, move them to the finalising set, and
-   darken them.
+   darken them (if darken_value is true).
 */
-void caml_final_update (void)
+static void generic_final_update (struct finalisable * final, int darken_value)
 {
   uintnat i, j, k;
   uintnat todo_count = 0;
 
-  Assert (old <= young);
-  for (i = 0; i < old; i++){
-    Assert (Is_block (final_table[i].val));
-    Assert (Is_in_heap (final_table[i].val));
-    if (Is_white_val (final_table[i].val)) ++ todo_count;
+  Assert (final->old <= final->young);
+  for (i = 0; i < final->old; i++){
+    Assert (Is_block (final->table[i].val));
+    Assert (Is_in_heap (final->table[i].val));
+    if (Is_white_val (final->table[i].val)){
+      ++ todo_count;
+    }
   }
 
+  /** invariant:
+      - 0 <= j <= i /\ 0 <= k <= i /\ 0 <= k <= todo_count
+      - i : index in final_table, before i all the values are black
+      (alive or in the minor heap) or the finalizer have been copied
+      in to_do_tl.
+      - j : index in final_table, before j all the values are black
+      (alive or in the minor heap), next available slot.
+      - k : index in to_do_tl, next available slot.
+  */
   if (todo_count > 0){
     alloc_to_do (todo_count);
     j = k = 0;
-    for (i = 0; i < old; i++){
-      Assert (Is_block (final_table[i].val));
-      Assert (Is_in_heap (final_table[i].val));
-      Assert (Tag_val (final_table[i].val) != Forward_tag);
-      if (Is_white_val (final_table[i].val)){
-        to_do_tl->item[k++] = final_table[i];
+    for (i = 0; i < final->old; i++){
+      Assert (Is_block (final->table[i].val));
+      Assert (Is_in_heap (final->table[i].val));
+      Assert (Tag_val (final->table[i].val) != Forward_tag);
+      if(Is_white_val (final->table[i].val)){
+        /** dead */
+        to_do_tl->item[k] = final->table[i];
+        if(!darken_value){
+          /* The value is not darken so the finalisation function
+             is called with unit not with the value */
+          to_do_tl->item[k].val = Val_unit;
+          to_do_tl->item[k].offset = 0;
+        };
+        k++;
       }else{
-        final_table[j++] = final_table[i];
+        /** alive */
+        final->table[j++] = final->table[i];
       }
     }
-    CAMLassert (i == old);
-    old = j;
-    for(;i < young; i++){
-      final_table[j++] = final_table[i];
+    CAMLassert (i == final->old);
+    CAMLassert (k == todo_count);
+    final->old = j;
+    for(;i < final->young; i++){
+      final->table[j++] = final->table[i];
     }
-    young = j;
+    final->young = j;
     to_do_tl->size = k;
-    for (i = 0; i < k; i++){
-      /* Note that item may already be dark due to multiple entries in
-         the final table. */
-      caml_darken (to_do_tl->item[i].val, NULL);
+    if(darken_value){
+      for (i = 0; i < k; i++){
+        /* Note that item may already be dark due to multiple entries in
+           the final table. */
+        caml_darken (to_do_tl->item[i].val, NULL);
+      }
     }
   }
 }
 
+void caml_final_update_mark_phase (){
+  generic_final_update(&finalisable_first, /* darken_value */ 1);
+}
+
+void caml_final_update_clean_phase (){
+  generic_final_update(&finalisable_last, /* darken_value */ 0);
+}
+
+
 static int running_finalisation_function = 0;
 
 /* Call the finalisation functions for the finalising set.
@@ -113,6 +171,9 @@ void caml_final_do_calls (void)
 {
   struct final f;
   value res;
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  void* saved_spacetime_trie_node_ptr;
+#endif
 
   if (running_finalisation_function) return;
   if (to_do_hd != NULL){
@@ -130,7 +191,17 @@ void caml_final_do_calls (void)
       -- to_do_hd->size;
       f = to_do_hd->item[to_do_hd->size];
       running_finalisation_function = 1;
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+      /* We record the finaliser's execution separately.
+         (The code of [caml_callback_exn] will do the hard work of finding
+         the correct place in the trie.) */
+      saved_spacetime_trie_node_ptr = caml_spacetime_trie_node_ptr;
+      caml_spacetime_trie_node_ptr = caml_spacetime_finaliser_trie_root;
+#endif
       res = caml_callback_exn (f.fun, f.val + f.offset);
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+      caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr;
+#endif
       running_finalisation_function = 0;
       if (Is_exception_result (res)) caml_raise (Extract_exception (res));
     }
@@ -144,15 +215,23 @@ void caml_final_do_calls (void)
 
 /* Call [*f] on the closures of the finalisable set and
    the closures and values of the finalising set.
-   This is called by the major GC through [caml_darken_all_roots].
+   This is called by the major GC [caml_darken_all_roots]
+   and by the compactor through [caml_do_roots]
 */
-void caml_final_do_strong_roots (scanning_action f)
+void caml_final_do_roots (scanning_action f)
 {
   uintnat i;
   struct to_do *todo;
 
-  Assert (old <= young);
-  for (i = 0; i < young; i++) Call_action (f, final_table[i].fun);
+  Assert (finalisable_first.old <= finalisable_first.young);
+  for (i = 0; i < finalisable_first.young; i++){
+    Call_action (f, finalisable_first.table[i].fun);
+  };
+
+  Assert (finalisable_last.old <= finalisable_last.young);
+  for (i = 0; i < finalisable_last.young; i++){
+    Call_action (f, finalisable_last.table[i].fun);
+  };
 
   for (todo = to_do_hd; todo != NULL; todo = todo->next){
     for (i = 0; i < todo->size; i++){
@@ -162,29 +241,122 @@ void caml_final_do_strong_roots (scanning_action f)
   }
 }
 
-/* Call [*f] on the values of the finalisable set.
-   This is called directly by the compactor.
+/* Call invert_root on the values of the finalisable set. This is called
+   directly by the compactor.
 */
-void caml_final_do_weak_roots (scanning_action f)
+void caml_final_invert_finalisable_values ()
 {
   uintnat i;
 
-  CAMLassert (old <= young);
-  for (i = 0; i < young; i++) Call_action (f, final_table[i].val);
+  CAMLassert (finalisable_first.old <= finalisable_first.young);
+  for (i = 0; i < finalisable_first.young; i++){
+    invert_root(finalisable_first.table[i].val,
+                &finalisable_first.table[i].val);
+  };
+
+  CAMLassert (finalisable_last.old <= finalisable_last.young);
+  for (i = 0; i < finalisable_last.young; i++){
+    invert_root(finalisable_last.table[i].val,
+                &finalisable_last.table[i].val);
+  };
 }
 
-/* Call [*f] on the closures and values of the recent set.
+/* Call [caml_oldify_one] on the closures and values of the recent set.
    This is called by the minor GC through [caml_oldify_local_roots].
 */
-void caml_final_do_young_roots (scanning_action f)
+void caml_final_oldify_young_roots ()
 {
   uintnat i;
 
-  Assert (old <= young);
-  for (i = old; i < young; i++){
-    Call_action (f, final_table[i].fun);
-    Call_action (f, final_table[i].val);
+  Assert (finalisable_first.old <= finalisable_first.young);
+  for (i = finalisable_first.old; i < finalisable_first.young; i++){
+    caml_oldify_one(finalisable_first.table[i].fun,
+                    &finalisable_first.table[i].fun);
+    caml_oldify_one(finalisable_first.table[i].val,
+                    &finalisable_first.table[i].val);
+  }
+
+  Assert (finalisable_last.old <= finalisable_last.young);
+  for (i = finalisable_last.old; i < finalisable_last.young; i++){
+    caml_oldify_one(finalisable_last.table[i].fun,
+                    &finalisable_last.table[i].fun);
+  }
+
+}
+
+static void generic_final_minor_update (struct finalisable * final)
+{
+  uintnat i, j, k;
+  uintnat todo_count = 0;
+
+  Assert (final->old <= final->young);
+  for (i = final->old; i < final->young; i++){
+    Assert (Is_block (final->table[i].val));
+    Assert (Is_in_heap_or_young (final->table[i].val));
+    if (Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){
+      ++ todo_count;
+    }
+  }
+
+  /** invariant:
+      - final->old <= j <= i /\ final->old <= k <= i /\ 0 <= k <= todo_count
+      - i : index in final_table, before i all the values are alive
+            or the finalizer have been copied in to_do_tl.
+      - j : index in final_table, before j all the values are alive,
+            next available slot.
+      - k : index in to_do_tl, next available slot.
+  */
+  if (todo_count > 0){
+    alloc_to_do (todo_count);
+    k = 0;
+    j = final->old;
+    for (i = final->old; i < final->young; i++){
+      Assert (Is_block (final->table[i].val));
+      Assert (Is_in_heap_or_young (final->table[i].val));
+      Assert (Tag_val (final->table[i].val) != Forward_tag);
+      if(Is_young(final->table[j].val) && Hd_val(final->table[i].val) != 0){
+        /** dead */
+        to_do_tl->item[k] = final->table[i];
+        /* The finalisation function is called with unit not with the value */
+        to_do_tl->item[k].val = Val_unit;
+        to_do_tl->item[k].offset = 0;
+        k++;
+      }else{
+        /** alive */
+        final->table[j++] = final->table[i];
+      }
+    }
+    CAMLassert (i == final->young);
+    CAMLassert (k == todo_count);
+    final->young = j;
+    to_do_tl->size = todo_count;
+  }
+
+  /** update the minor value to the copied major value */
+  for (i = final->old; i < final->young; i++){
+    Assert (Is_block (final->table[i].val));
+    Assert (Is_in_heap_or_young (final->table[i].val));
+    if (Is_young(final->table[i].val)) {
+      CAMLassert (Hd_val(final->table[i].val) == 0);
+      final->table[i].val = Field(final->table[i].val,0);
+    }
   }
+
+  /** check invariant */
+  Assert (final->old <= final->young);
+  for (i = 0; i < final->young; i++){
+    CAMLassert( Is_in_heap(final->table[i].val) );
+  };
+
+}
+
+/* At the end of minor collection update the finalise_last roots in
+   minor heap when moved to major heap or moved them to the finalising
+   set when dead.
+*/
+void caml_final_update_minor_roots ()
+{
+  generic_final_minor_update(&finalisable_last);
 }
 
 /* Empty the recent set into the finalisable set.
@@ -193,11 +365,12 @@ void caml_final_do_young_roots (scanning_action f)
 */
 void caml_final_empty_young (void)
 {
-  old = young;
+  finalisable_first.old = finalisable_first.young;
+  finalisable_last.old = finalisable_last.young;
 }
 
 /* Put (f,v) in the recent set. */
-CAMLprim value caml_final_register (value f, value v)
+static void generic_final_register (struct finalisable *final, value f, value v)
 {
   if (!Is_block (v)
       || !Is_in_heap_or_young(v)
@@ -206,38 +379,65 @@ CAMLprim value caml_final_register (value f, value v)
       || Tag_val (v) == Forward_tag) {
     caml_invalid_argument ("Gc.finalise");
   }
-  Assert (old <= young);
+  Assert (final->old <= final->young);
 
-  if (young >= size){
-    if (final_table == NULL){
+  if (final->young >= final->size){
+    if (final->table == NULL){
       uintnat new_size = 30;
-      final_table = caml_stat_alloc (new_size * sizeof (struct final));
-      Assert (old == 0);
-      Assert (young == 0);
-      size = new_size;
+      final->table = caml_stat_alloc (new_size * sizeof (struct final));
+      Assert (final->old == 0);
+      Assert (final->young == 0);
+      final->size = new_size;
     }else{
-      uintnat new_size = size * 2;
-      final_table = caml_stat_resize (final_table,
+      uintnat new_size = final->size * 2;
+      final->table = caml_stat_resize (final->table,
                                       new_size * sizeof (struct final));
-      size = new_size;
+      final->size = new_size;
     }
   }
-  Assert (young < size);
-  final_table[young].fun = f;
+  Assert (final->young < final->size);
+  final->table[final->young].fun = f;
   if (Tag_val (v) == Infix_tag){
-    final_table[young].offset = Infix_offset_val (v);
-    final_table[young].val = v - Infix_offset_val (v);
+    final->table[final->young].offset = Infix_offset_val (v);
+    final->table[final->young].val = v - Infix_offset_val (v);
   }else{
-    final_table[young].offset = 0;
-    final_table[young].val = v;
+    final->table[final->young].offset = 0;
+    final->table[final->young].val = v;
   }
-  ++ young;
+  ++ final->young;
+
+}
+
+CAMLprim value caml_final_register (value f, value v){
+  generic_final_register(&finalisable_first, f, v);
+  return Val_unit;
+}
 
+CAMLprim value caml_final_register_called_without_value (value f, value v){
+  generic_final_register(&finalisable_last, f, v);
   return Val_unit;
 }
 
+
 CAMLprim value caml_final_release (value unit)
 {
   running_finalisation_function = 0;
   return Val_unit;
 }
+
+static void gen_final_invariant_check(struct finalisable *final){
+  uintnat i;
+
+  CAMLassert (final->old <= final->young);
+  for (i = 0; i < final->old; i++){
+    CAMLassert( Is_in_heap(final->table[i].val) );
+  };
+  for (i = final->old; i < final->young; i++){
+    CAMLassert( Is_in_heap_or_young(final->table[i].val) );
+  };
+}
+
+void caml_final_invariant_check(void){
+  gen_final_invariant_check(&finalisable_first);
+  gen_final_invariant_check(&finalisable_last);
+}

diff --git a/byterun/fix_code.c b/byterun/fix_code.c
index 45d52cadc034cce70014b8eb7a9f5792d799b7db..b55d8ffb65f3ede2a94e89094e8fbf500c8d6c85 100644 (file)
--- a/byterun/fix_code.c
+++ b/byterun/fix_code.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Handling of blocks of bytecode (endianness switch, threading). */
 
 #include "caml/config.h"

diff --git a/byterun/floats.c b/byterun/floats.c
index 41204da28dfac7305b764ddaa004db9faabf5a88..8792b2522c6939f7f6322783dff4b83f16296398 100644 (file)
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The interface of this file is in "caml/mlvalues.h" and "caml/alloc.h" */
 
 #include <math.h>
@@ -241,6 +243,7 @@ static int caml_float_of_hex(const char * s, double * res)
     }
     }
   }
+  if (n_bits == 0) return -1;
   /* Convert mantissa to FP.  We use a signed conversion because we can
      (m has 60 bits at most) and because it is faster
      on several architectures. */
@@ -555,34 +558,41 @@ CAMLprim value caml_copysign_float(value f, value g)
   return caml_copy_double(caml_copysign(Double_val(f), Double_val(g)));
 }
 
-CAMLprim value caml_eq_float(value f, value g)
-{
-  return Val_bool(Double_val(f) == Double_val(g));
-}
+#ifdef LACKS_SANE_NAN
 
-CAMLprim value caml_neq_float(value f, value g)
+CAMLprim value caml_neq_float(value vf, value vg)
 {
-  return Val_bool(Double_val(f) != Double_val(g));
+  double f = Double_val(vf);
+  double g = Double_val(vg);
+  return Val_bool(isnan(f) || isnan(g) || f != g);
 }
 
-CAMLprim value caml_le_float(value f, value g)
-{
-  return Val_bool(Double_val(f) <= Double_val(g));
+#define DEFINE_NAN_CMP(op) (value vf, value vg) \
+{ \
+  double f = Double_val(vf); \
+  double g = Double_val(vg); \
+  return Val_bool(!isnan(f) && !isnan(g) && f op g); \
 }
 
-CAMLprim value caml_lt_float(value f, value g)
+intnat caml_float_compare_unboxed(double f, double g)
 {
-  return Val_bool(Double_val(f) < Double_val(g));
+  /* Insane => nan == everything && nan < everything && nan > everything */
+  if (isnan(f) && isnan(g)) return 0;
+  if (!isnan(g) && f < g) return -1;
+  if (f != g) return 1;
+  return 0;
 }
 
-CAMLprim value caml_ge_float(value f, value g)
+#else
+
+CAMLprim value caml_neq_float(value f, value g)
 {
-  return Val_bool(Double_val(f) >= Double_val(g));
+  return Val_bool(Double_val(f) != Double_val(g));
 }
 
-CAMLprim value caml_gt_float(value f, value g)
-{
-  return Val_bool(Double_val(f) > Double_val(g));
+#define DEFINE_NAN_CMP(op) (value f, value g) \
+{ \
+  return Val_bool(Double_val(f) op Double_val(g)); \
 }
 
 intnat caml_float_compare_unboxed(double f, double g)
@@ -594,6 +604,14 @@ intnat caml_float_compare_unboxed(double f, double g)
   return (f > g) - (f < g) + (f == f) - (g == g);
 }
 
+#endif
+
+CAMLprim value caml_eq_float DEFINE_NAN_CMP(==)
+CAMLprim value caml_le_float DEFINE_NAN_CMP(<=)
+CAMLprim value caml_lt_float DEFINE_NAN_CMP(<)
+CAMLprim value caml_ge_float DEFINE_NAN_CMP(>=)
+CAMLprim value caml_gt_float DEFINE_NAN_CMP(>)
+
 CAMLprim value caml_float_compare(value vf, value vg)
 {
   return Val_int(caml_float_compare_unboxed(Double_val(vf),Double_val(vg)));

diff --git a/byterun/freelist.c b/byterun/freelist.c
index eaac36c4429165205879d880e13eb1eac064a80d..3633d77b9e23fbde9e7275a7eab2c0ee271e3942 100644 (file)
--- a/byterun/freelist.c
+++ b/byterun/freelist.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #define FREELIST_DEBUG 0
 #if FREELIST_DEBUG
 #include <stdio.h>
@@ -587,7 +589,8 @@ void caml_make_free_blocks (value *p, mlsize_t size, int do_merge, int color)
     }else{
       sz = size;
     }
-    *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color);
+    *(header_t *)p =
+      Make_header (Wosize_whsize (sz), 0, color);
     if (do_merge) caml_fl_merge_block (Val_hp (p));
     size -= sz;
     p += sz;

diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
index 51a2d79e440e858f5751c2cb15067b452c56827d..4e3f833cc0160e6e26a63d743b433204dbaeb337 100644 (file)
--- a/byterun/gc_ctrl.c
+++ b/byterun/gc_ctrl.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include "caml/alloc.h"
 #include "caml/backtrace.h"
 #include "caml/compact.h"
@@ -29,7 +31,7 @@
 #include "caml/mlvalues.h"
 #include "caml/signals.h"
 #ifdef NATIVE_CODE
-#include "stack.h"
+#include "caml/stack.h"
 #else
 #include "caml/stacks.h"
 #endif
@@ -213,6 +215,10 @@ static value heap_stats (int returnstats)
     chunk = Chunk_next (chunk);
   }
 
+#ifdef DEBUG
+  caml_final_invariant_check();
+#endif
+
   Assert (heap_chunks == caml_stat_heap_chunks);
   Assert (live_words + free_words + fragments == caml_stat_heap_wsz);
 
@@ -307,6 +313,18 @@ CAMLprim value caml_gc_quick_stat(value v)
   CAMLreturn (res);
 }
 
+double caml_gc_minor_words_unboxed()
+{
+  return (caml_stat_minor_words
+          + (double) (caml_young_alloc_end - caml_young_ptr));
+}
+
+CAMLprim value caml_gc_minor_words(value v)
+{
+  CAMLparam0 ();   /* v is ignored */
+  CAMLreturn(caml_copy_double(caml_gc_minor_words_unboxed()));
+}
+
 CAMLprim value caml_gc_counters(value v)
 {
   CAMLparam0 ();   /* v is ignored */
@@ -462,7 +480,7 @@ static void test_and_compact (void)
   caml_gc_message (0x200, "Estimated overhead (lower bound) = %"
                           ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                    (uintnat) fp);
-  if (fp >= caml_percent_max && caml_stat_heap_chunks > 1){
+  if (fp >= caml_percent_max){
     caml_gc_message (0x200, "Automatic compaction triggered.\n", 0);
     caml_compact_heap ();
   }
@@ -648,7 +666,8 @@ CAMLprim value caml_ml_enable_runtime_warnings(value vbool)
   return Val_unit;
 }
 
-CAMLprim value caml_ml_runtime_warnings_enabled(value vbool)
+CAMLprim value caml_ml_runtime_warnings_enabled(value unit)
 {
+  CAMLassert (unit == Val_unit);
   return Val_bool(caml_runtime_warnings);
 }

diff --git a/byterun/globroots.c b/byterun/globroots.c
index 138b808b899f80580796ac14eb3247b56b070203..44493dbe2e96f09cc156be6719843394ac5f878b 100644 (file)
--- a/byterun/globroots.c
+++ b/byterun/globroots.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Registration of global memory roots */
 
 #include "caml/memory.h"
@@ -216,9 +218,9 @@ CAMLexport void caml_remove_generational_global_root(value *r)
 {
   value v = *r;
   if (Is_block(v)) {
-    if (Is_young(v))
+    if (Is_in_heap_or_young(v))
       caml_delete_global_root(&caml_global_roots_young, r);
-    else if (Is_in_heap(v))
+    if (Is_in_heap(v))
       caml_delete_global_root(&caml_global_roots_old, r);
   }
 }
@@ -254,9 +256,9 @@ CAMLexport void caml_modify_generational_global_root(value *r, value newval)
        the root should be removed. If [oldval] is young, this will happen
        anyway at the next minor collection, but it is safer to delete it
        here. */
-    if (Is_young(oldval))
+    if (Is_in_heap_or_young(oldval))
       caml_delete_global_root(&caml_global_roots_young, r);
-    else if (Is_in_heap(oldval))
+    if (Is_in_heap(oldval))
       caml_delete_global_root(&caml_global_roots_old, r);
   }
   /* end PR#4704 */

diff --git a/byterun/hash.c b/byterun/hash.c
index 6089dba278cea8e7f9d9ff2321a7f7b2660cc1e8..f59c8fbc1b2dce81b83eaab8a20f99160d482163 100644 (file)
--- a/byterun/hash.c
+++ b/byterun/hash.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The generic hashing primitive */
 
 /* The interface of this file is in "mlvalues.h" (for [caml_hash_variant])

diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c
index bf2d3038516214e6fc2dbd0fa5f64c62d900fd11..c2ad8348b413d9ab837b8217a64a470e6b37b3a5 100644 (file)
--- a/byterun/instrtrace.c
+++ b/byterun/instrtrace.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Trace the instructions executed */
 
 #ifdef DEBUG

diff --git a/byterun/intern.c b/byterun/intern.c
index 96196ff2deb70870a5e120bab78fe111e56295f1..9c6c4cea5568e1593b496abf4442aa164762c166 100644 (file)
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Structured input, compact format */
 
 /* The interface of this file is "caml/intext.h" */
@@ -363,7 +365,7 @@ static void intern_rec(value *dest)
       } else {
         v = Val_hp(intern_dest);
         if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-        *intern_dest = Make_header(size, tag, intern_color);
+        *intern_dest = Make_header_allocated_here(size, tag, intern_color);
         intern_dest += 1 + size;
         /* For objects, we need to freshen the oid */
         if (tag == Object_tag) {
@@ -393,7 +395,7 @@ static void intern_rec(value *dest)
       size = (len + sizeof(value)) / sizeof(value);
       v = Val_hp(intern_dest);
       if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-      *intern_dest = Make_header(size, String_tag, intern_color);
+      *intern_dest = Make_header_allocated_here(size, String_tag, intern_color);
       intern_dest += 1 + size;
       Field(v, size - 1) = 0;
       ofs_ind = Bsize_wsize(size) - 1;
@@ -465,7 +467,8 @@ static void intern_rec(value *dest)
       case CODE_DOUBLE_BIG:
         v = Val_hp(intern_dest);
         if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-        *intern_dest = Make_header(Double_wosize, Double_tag, intern_color);
+        *intern_dest = Make_header_allocated_here(Double_wosize, Double_tag,
+                                                  intern_color);
         intern_dest += 1 + Double_wosize;
         readfloat((double *) v, code);
         break;
@@ -476,7 +479,8 @@ static void intern_rec(value *dest)
         size = len * Double_wosize;
         v = Val_hp(intern_dest);
         if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-        *intern_dest = Make_header(size, Double_array_tag, intern_color);
+        *intern_dest = Make_header_allocated_here(size, Double_array_tag,
+                                                  intern_color);
         intern_dest += 1 + size;
         readfloats((double *) v, len, code);
         break;
@@ -527,7 +531,8 @@ static void intern_rec(value *dest)
         size = 1 + (size + sizeof(value) - 1) / sizeof(value);
         v = Val_hp(intern_dest);
         if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-        *intern_dest = Make_header(size, Custom_tag, intern_color);
+        *intern_dest = Make_header_allocated_here(size, Custom_tag,
+                                                  intern_color);
         Custom_ops_val(v) = ops;
 
         if (ops->finalize != NULL && Is_young(v)) {
@@ -554,7 +559,8 @@ static void intern_rec(value *dest)
   intern_free_stack();
 }
 
-static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
+static void intern_alloc(mlsize_t whsize, mlsize_t num_objects,
+      int outside_heap)
 {
   mlsize_t wosize;
 
@@ -564,7 +570,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
     return;
   }
   wosize = Wosize_whsize(whsize);
-  if (wosize > Max_wosize) {
+  if (wosize > Max_wosize || outside_heap) {
     /* Round desired size up to next page */
     asize_t request =
       ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
@@ -573,7 +579,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
       intern_cleanup();
       caml_raise_out_of_memory();
     }
-    intern_color = caml_allocation_color(intern_extra_block);
+    intern_color =
+      outside_heap ? Caml_black : caml_allocation_color(intern_extra_block);
     intern_dest = (header_t *) intern_extra_block;
     Assert (intern_block == 0);
   } else {
@@ -686,8 +693,9 @@ static void caml_parse_header(char * fun_name,
 
 /* Reading from a channel */
 
-value caml_input_val(struct channel *chan)
+static value caml_input_val_core(struct channel *chan, int outside_heap)
 {
+  intnat r;
   char header[32];
   struct marshal_header h;
   char * block;
@@ -696,12 +704,15 @@ value caml_input_val(struct channel *chan)
   if (! caml_channel_binary_mode(chan))
     caml_failwith("input_value: not a binary channel");
   /* Read and parse the header */
-  if (caml_really_getblock(chan, header, 20) == 0)
+  r = caml_really_getblock(chan, header, 20);
+  if (r == 0)
+    caml_raise_end_of_file();
+  else if (r < 20)
     caml_failwith("input_value: truncated object");
   intern_src = (unsigned char *) header;
   if (read32u() == Intext_magic_number_big) {
     /* Finish reading the header */
-    if (caml_really_getblock(chan, header + 20, 32 - 20) == 0)
+    if (caml_really_getblock(chan, header + 20, 32 - 20) < 32 - 20)
       caml_failwith("input_value: truncated object");
   }
   intern_src = (unsigned char *) header;
@@ -712,21 +723,32 @@ value caml_input_val(struct channel *chan)
      can take place (via signal handlers or context switching in systhreads),
      and [intern_input] may change.  So, wait until [caml_really_getblock]
      is over before using [intern_input] and the other global vars. */
-  if (caml_really_getblock(chan, block, h.data_len) == 0) {
+  if (caml_really_getblock(chan, block, h.data_len) < h.data_len) {
     caml_stat_free(block);
     caml_failwith("input_value: truncated object");
   }
   /* Initialize global state */
   intern_init(block, block);
-  intern_alloc(h.whsize, h.num_objects);
+  intern_alloc(h.whsize, h.num_objects, outside_heap);
   /* Fill it in */
   intern_rec(&res);
-  intern_add_to_heap(h.whsize);
+  if (!outside_heap) {
+    intern_add_to_heap(h.whsize);
+  } else {
+    caml_disown_for_heap(intern_extra_block);
+    intern_extra_block = NULL;
+    intern_block = 0;
+  }
   /* Free everything */
   intern_cleanup();
   return caml_check_urgent_gc(res);
 }
 
+value caml_input_val(struct channel* chan)
+{
+  return caml_input_val_core(chan, 0);
+}
+
 CAMLprim value caml_input_value(value vchan)
 {
   CAMLparam1 (vchan);
@@ -741,6 +763,18 @@ CAMLprim value caml_input_value(value vchan)
 
 /* Reading from memory-resident blocks */
 
+CAMLprim value caml_input_value_to_outside_heap(value vchan)
+{
+  CAMLparam1 (vchan);
+  struct channel * chan = Channel(vchan);
+  CAMLlocal1 (res);
+
+  Lock(chan);
+  res = caml_input_val_core(chan, 1);
+  Unlock(chan);
+  CAMLreturn (res);
+}
+
 CAMLexport value caml_input_val_from_string(value str, intnat ofs)
 {
   CAMLparam1 (str);
@@ -753,7 +787,7 @@ CAMLexport value caml_input_val_from_string(value str, intnat ofs)
   if (ofs + h.header_len + h.data_len > caml_string_length(str))
     caml_failwith("input_val_from_string: bad length");
   /* Allocate result */
-  intern_alloc(h.whsize, h.num_objects);
+  intern_alloc(h.whsize, h.num_objects, 0);
   intern_src = &Byte_u(str, ofs + h.header_len); /* If a GC occurred */
   /* Fill it in */
   intern_rec(&obj);
@@ -772,7 +806,7 @@ static value input_val_from_block(struct marshal_header * h)
 {
   value obj;
   /* Allocate result */
-  intern_alloc(h->whsize, h->num_objects);
+  intern_alloc(h->whsize, h->num_objects, 0);
   /* Fill it in */
   intern_rec(&obj);
   intern_add_to_heap(h->whsize);

diff --git a/byterun/interp.c b/byterun/interp.c
index f039b9a6a9852942460ccd7d989a3a2db421211c..9b3e0ac22788c12fa78317b26f40da59605b8735 100644 (file)
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The bytecode interpreter */
 #include <stdio.h>
 #include "caml/alloc.h"

diff --git a/byterun/ints.c b/byterun/ints.c
index 6141f2b99cd7813cf1a8b535958d41c20b5a6d65..c49f42f0efc9cc810b484d3ce5bdfb6a269862cc 100644 (file)
--- a/byterun/ints.c
+++ b/byterun/ints.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <stdio.h>
 #include <string.h>
 #include "caml/alloc.h"
@@ -499,18 +501,25 @@ value caml_int64_direct_bswap(value v)
 { return caml_swap64(v); }
 #endif
 
+/* Microsoft introduced the LL integer literal suffix in Visual C++ .NET 2003 */
+#if defined(_MSC_VER) && _MSC_VER < 1400
+#define INT64_LITERAL(s) s ## i64
+#else
+#define INT64_LITERAL(s) s ## LL
+#endif
+
 CAMLprim value caml_int64_bswap(value v)
 {
   int64_t x = Int64_val(v);
   return caml_copy_int64
-    (((x & 0x00000000000000FFULL) << 56) |
-     ((x & 0x000000000000FF00ULL) << 40) |
-     ((x & 0x0000000000FF0000ULL) << 24) |
-     ((x & 0x00000000FF000000ULL) << 8) |
-     ((x & 0x000000FF00000000ULL) >> 8) |
-     ((x & 0x0000FF0000000000ULL) >> 24) |
-     ((x & 0x00FF000000000000ULL) >> 40) |
-     ((x & 0xFF00000000000000ULL) >> 56));
+    (((x & INT64_LITERAL(0x00000000000000FFU)) << 56) |
+     ((x & INT64_LITERAL(0x000000000000FF00U)) << 40) |
+     ((x & INT64_LITERAL(0x0000000000FF0000U)) << 24) |
+     ((x & INT64_LITERAL(0x00000000FF000000U)) << 8) |
+     ((x & INT64_LITERAL(0x000000FF00000000U)) >> 8) |
+     ((x & INT64_LITERAL(0x0000FF0000000000U)) >> 24) |
+     ((x & INT64_LITERAL(0x00FF000000000000U)) >> 40) |
+     ((x & INT64_LITERAL(0xFF00000000000000U)) >> 56));
 }
 
 CAMLprim value caml_int64_of_int(value v)

diff --git a/byterun/io.c b/byterun/io.c
index b9f5af36568e9e9f1b531bae2c90d335cecc1e64..b11eeccf18632f01027279a58219efb673830923 100644 (file)
--- a/byterun/io.c
+++ b/byterun/io.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Buffered input/output. */
 
 #include <errno.h>
@@ -110,7 +112,7 @@ static void unlink_channel(struct channel *channel)
 
 CAMLexport void caml_close_channel(struct channel *channel)
 {
-  close(channel->fd);
+  CAML_SYS_CLOSE(channel->fd);
   if (channel->refcount > 0) return;
   if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel);
   unlink_channel(channel);
@@ -186,10 +188,10 @@ CAMLexport void caml_putword(struct channel *channel, uint32_t w)
 {
   if (! caml_channel_binary_mode(channel))
     caml_failwith("output_binary_int: not a binary channel");
-  putch(channel, w >> 24);
-  putch(channel, w >> 16);
-  putch(channel, w >> 8);
-  putch(channel, w);
+  caml_putch(channel, w >> 24);
+  caml_putch(channel, w >> 16);
+  caml_putch(channel, w >> 8);
+  caml_putch(channel, w);
 }
 
 CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len)
@@ -276,7 +278,7 @@ CAMLexport uint32_t caml_getword(struct channel *channel)
     caml_failwith("input_binary_int: not a binary channel");
   res = 0;
   for(i = 0; i < 4; i++) {
-    res = (res << 8) + getch(channel);
+    res = (res << 8) + caml_getch(channel);
   }
   return res;
 }
@@ -307,16 +309,18 @@ CAMLexport int caml_getblock(struct channel *channel, char *p, intnat len)
   }
 }
 
-CAMLexport int caml_really_getblock(struct channel *chan, char *p, intnat n)
+/* Returns the number of bytes read. */
+CAMLexport intnat caml_really_getblock(struct channel *chan, char *p, intnat n)
 {
+  intnat k = n;
   int r;
-  while (n > 0) {
-    r = caml_getblock(chan, p, n);
+  while (k > 0) {
+    r = caml_getblock(chan, p, k);
     if (r == 0) break;
     p += r;
-    n -= r;
+    k -= r;
   }
-  return (n == 0);
+  return n - k;
 }
 
 CAMLexport void caml_seek_in(struct channel *channel, file_offset dest)
@@ -530,7 +534,7 @@ CAMLprim value caml_ml_close_channel(value vchannel)
 
   if (do_syscall) {
     caml_enter_blocking_section();
-    result = close(fd);
+    result = CAML_SYS_CLOSE(fd);
     caml_leave_blocking_section();
   }
 
@@ -616,7 +620,7 @@ CAMLprim value caml_ml_output_char(value vchannel, value ch)
   struct channel * channel = Channel(vchannel);
 
   Lock(channel);
-  putch(channel, Long_val(ch));
+  caml_putch(channel, Long_val(ch));
   Unlock(channel);
   CAMLreturn (Val_unit);
 }
@@ -645,7 +649,7 @@ CAMLprim value caml_ml_output_partial(value vchannel, value buff, value start,
   CAMLreturn (Val_int(res));
 }
 
-CAMLprim value caml_ml_output(value vchannel, value buff, value start,
+CAMLprim value caml_ml_output_bytes(value vchannel, value buff, value start,
                               value length)
 {
   CAMLparam4 (vchannel, buff, start, length);
@@ -654,6 +658,8 @@ CAMLprim value caml_ml_output(value vchannel, value buff, value start,
   intnat len = Long_val(length);
 
   Lock(channel);
+    /* We cannot call caml_really_putblock here because buff may move
+       during caml_write_fd */
     while (len > 0) {
       int written = caml_putblock(channel, &Byte(buff, pos), len);
       pos += written;
@@ -663,6 +669,12 @@ CAMLprim value caml_ml_output(value vchannel, value buff, value start,
   CAMLreturn (Val_unit);
 }
 
+CAMLprim value caml_ml_output(value vchannel, value buff, value start,
+                              value length)
+{
+  return caml_ml_output_bytes (vchannel, buff, start, length);
+}
+
 CAMLprim value caml_ml_seek_out(value vchannel, value pos)
 {
   CAMLparam2 (vchannel, pos);
@@ -704,7 +716,7 @@ CAMLprim value caml_ml_input_char(value vchannel)
   unsigned char c;
 
   Lock(channel);
-  c = getch(channel);
+  c = caml_getch(channel);
   Unlock(channel);
   CAMLreturn (Val_long(c));
 }

diff --git a/byterun/lexing.c b/byterun/lexing.c
index 567b7a76e0d19a2699f67a2841794122d386bcee..b1049904252847da478aff32011930d02e2cfafe 100644 (file)
--- a/byterun/lexing.c
+++ b/byterun/lexing.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The table-driven automaton for lexers generated by camllex. */
 
 #include "caml/fail.h"

diff --git a/byterun/main.c b/byterun/main.c
index 2a0172845ad2d4cfed85c012b7a1fe95aeac048e..e773dd9bd540b6e991a14a7c1f35ca9502596868 100644 (file)
--- a/byterun/main.c
+++ b/byterun/main.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Main entry point (can be overridden by a user-provided main()
    function that calls caml_main() later). */
 

diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index 4e75012e6aea0a2063b7346efda5ba0605b7be67..5a3e4cb1a3a609f94cb254b60a4eff7de99e6b59 100644 (file)
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <limits.h>
 #include <math.h>
 
@@ -399,7 +401,7 @@ static void mark_slice (intnat work)
       if (Tag_hd (hd) < No_scan_tag){
         start = size < start ? size : start;
         end = size < end ? size : end;
-        CAMLassert (end > start);
+        CAMLassert (end >= start);
         INSTR (slice_fields += end - start;)
         INSTR (if (size > end)
                  CAML_INSTR_INT ("major/mark/slice/remain", size - end);)
@@ -469,7 +471,7 @@ static void mark_slice (intnat work)
           /* Subphase_mark_main is done.
              Mark finalised values. */
           gray_vals_cur = gray_vals_ptr;
-          caml_final_update ();
+          caml_final_update_mark_phase ();
           gray_vals_ptr = gray_vals_cur;
           if (gray_vals_ptr > gray_vals){
             v = *--gray_vals_ptr;
@@ -481,17 +483,18 @@ static void mark_slice (intnat work)
       }
         break;
       case Subphase_mark_final: {
+        /** The set of unreachable value will not change anymore for
+            this cycle. Start clean phase. */
+        caml_gc_phase = Phase_clean;
+        caml_final_update_clean_phase ();
         if (caml_ephe_list_head != (value) NULL){
           /* Initialise the clean phase. */
-          caml_gc_phase = Phase_clean;
           ephes_to_check = &caml_ephe_list_head;
-          work = 0;
         } else {
-          /* Initialise the sweep phase,
-           shortcut the unneeded clean phase. */
+          /* Initialise the sweep phase. */
           init_sweep_phase();
-          work = 0;
         }
+          work = 0;
       }
         break;
       default: Assert (0);

diff --git a/byterun/md5.c b/byterun/md5.c
index 3d5ae496b8caa4e108a395bb712e5c798e33fbec..2e1280105eb4512b65e0ec4c593667924ac631f7 100644 (file)
--- a/byterun/md5.c
+++ b/byterun/md5.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <string.h>
 #include "caml/alloc.h"
 #include "caml/fail.h"

diff --git a/byterun/memory.c b/byterun/memory.c
index 4b52b82004a364e99c4e1602ad46e94d16366b97..038eaa56742c2b5e11bf487f818103a88d408126 100644 (file)
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <stdlib.h>
 #include <string.h>
 #include "caml/address_class.h"
@@ -284,6 +286,15 @@ char *caml_alloc_for_heap (asize_t request)
   }
 }
 
+/* Use this function if a block allocated with [caml_alloc_for_heap] is
+   not actually going to be added to the heap.  The caller is responsible
+   for freeing it. */
+void caml_disown_for_heap (char* mem)
+{
+  /* Currently a no-op. */
+  (void)mem; /* can CAMLunused_{start,end} be used here? */
+}
+
 /* Use this function to free a block allocated with [caml_alloc_for_heap]
    if you don't add it with [caml_add_to_heap].
 */
@@ -392,7 +403,9 @@ static value *expand_heap (mlsize_t request)
     Field (Val_hp (hp), 0) = (value) NULL;
   }else{
     Field (Val_hp (prev), 0) = (value) NULL;
-    if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white);
+    if (remain == 1) {
+      Hd_hp (hp) = Make_header_allocated_here (0, 0, Caml_white);
+    }
   }
   Assert (Wosize_hp (mem) >= request);
   if (caml_add_to_heap ((char *) mem) != 0){
@@ -459,7 +472,7 @@ color_t caml_allocation_color (void *hp)
 }
 
 static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag,
-                                        int raise_oom)
+                                        int raise_oom, uintnat profinfo)
 {
   header_t *hp;
   value *new_block;
@@ -490,14 +503,16 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag,
   /* Inline expansion of caml_allocation_color. */
   if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean
       || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
-    Hd_hp (hp) = Make_header (wosize, tag, Caml_black);
+    Hd_hp (hp) = Make_header_with_profinfo (wosize, tag, Caml_black, profinfo);
   }else{
     Assert (caml_gc_phase == Phase_idle
             || (caml_gc_phase == Phase_sweep
                 && (addr)hp < (addr)caml_gc_sweep_hp));
-    Hd_hp (hp) = Make_header (wosize, tag, Caml_white);
+    Hd_hp (hp) = Make_header_with_profinfo (wosize, tag, Caml_white, profinfo);
   }
-  Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp)));
+  Assert (Hd_hp (hp)
+    == Make_header_with_profinfo (wosize, tag, caml_allocation_color (hp),
+                                  profinfo));
   caml_allocated_words += Whsize_wosize (wosize);
   if (caml_allocated_words > caml_minor_heap_wsz){
     CAML_INSTR_INT ("request_major/alloc_shr@", 1);
@@ -516,13 +531,35 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag,
 
 CAMLexport value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t tag)
 {
-  return caml_alloc_shr_aux(wosize, tag, 0);
+  return caml_alloc_shr_aux(wosize, tag, 0, 0);
+}
+
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#include "spacetime.h"
+
+CAMLexport value caml_alloc_shr_with_profinfo (mlsize_t wosize, tag_t tag,
+                                               intnat profinfo)
+{
+  return caml_alloc_shr_aux(wosize, tag, 1, profinfo);
 }
 
+CAMLexport value caml_alloc_shr_preserving_profinfo (mlsize_t wosize,
+  tag_t tag, header_t old_header)
+{
+  return caml_alloc_shr_with_profinfo (wosize, tag, Profinfo_hd(old_header));
+}
+
+CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
+{
+  return caml_alloc_shr_with_profinfo (wosize, tag,
+    caml_spacetime_my_profinfo (NULL, wosize));
+}
+#else
 CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
 {
-  return caml_alloc_shr_aux(wosize, tag, 1);
+  return caml_alloc_shr_aux (wosize, tag, 1, 0);
 }
+#endif
 
 /* Dependent memory is all memory blocks allocated out of the heap
    that depend on the GC (and finalizers) for deallocation.

diff --git a/byterun/meta.c b/byterun/meta.c
index 14205f1fe392d63f8e262f19abe53f8062624ed6..9ec0358bbb55d0a13ada7066b49535043a2816b4 100644 (file)
--- a/byterun/meta.c
+++ b/byterun/meta.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Primitives for the toplevel */
 
 #include <string.h>

diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index 727fdb014aec91180daff6658e1dfc25e3b366fc..2596e7a5341cadb2d49d5d51c6eefa4350068741 100644 (file)
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <string.h>
 #include "caml/custom.h"
 #include "caml/config.h"
@@ -37,7 +39,7 @@
        this interval.
    [caml_young_alloc_start]...[caml_young_alloc_end]
        The allocation arena: newly-allocated blocks are carved from
-       this interval.
+       this interval, starting at [caml_young_alloc_end].
    [caml_young_alloc_mid] is the mid-point of this interval.
    [caml_young_ptr], [caml_young_trigger], [caml_young_limit]
        These pointers are all inside the allocation arena.
@@ -191,7 +193,7 @@ void caml_oldify_one (value v, value *p)
         value field0;
 
         sz = Wosize_hd (hd);
-        result = caml_alloc_shr (sz, tag);
+        result = caml_alloc_shr_preserving_profinfo (sz, tag, hd);
         *p = result;
         field0 = Field (v, 0);
         Hd_val (v) = 0;            /* Set forward flag */
@@ -208,7 +210,7 @@ void caml_oldify_one (value v, value *p)
         }
       }else if (tag >= No_scan_tag){
         sz = Wosize_hd (hd);
-        result = caml_alloc_shr (sz, tag);
+        result = caml_alloc_shr_preserving_profinfo (sz, tag, hd);
         for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
         Hd_val (v) = 0;            /* Set forward flag */
         Field (v, 0) = result;     /*  and forward pointer. */
@@ -237,7 +239,7 @@ void caml_oldify_one (value v, value *p)
         if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
           /* Do not short-circuit the pointer.  Copy as a normal block. */
           Assert (Wosize_hd (hd) == 1);
-          result = caml_alloc_shr (1, Forward_tag);
+          result = caml_alloc_shr_preserving_profinfo (1, Forward_tag, hd);
           *p = result;
           Hd_val (v) = 0;             /* Set (GC) forward flag */
           Field (v, 0) = result;      /*  and forward pointer. */
@@ -365,6 +367,8 @@ void caml_empty_minor_heap (void)
         }
       }
     }
+    /* Update the OCaml finalise_last values */
+    caml_final_update_minor_roots();
     /* Run custom block finalisation of dead minor values */
     for (elt = caml_custom_table.base; elt < caml_custom_table.ptr; elt++){
       value v = elt->block;
@@ -394,6 +398,7 @@ void caml_empty_minor_heap (void)
     ++ caml_stat_minor_collections;
     if (caml_minor_gc_end_hook != NULL) (*caml_minor_gc_end_hook) ();
   }else{
+    /* The minor heap is empty nothing to do. */
     caml_final_empty_young ();
   }
 #ifdef DEBUG

diff --git a/byterun/misc.c b/byterun/misc.c
index 9c6ded0d359a0c1e787d10cbb3699baa925085a0..447b933fc7273213e312ae52c4ebd93db00fe6e5 100644 (file)
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <stdio.h>
 #include <string.h>
 #include <stdarg.h>
@@ -105,6 +107,9 @@ char *caml_aligned_malloc (asize_t size, int modulo, void **block)
   return (char *) (aligned_mem - modulo);
 }
 
+/* If you change the caml_ext_table* functions, also update
+   asmrun/spacetime.c:find_trie_node_from_libunwind. */
+
 void caml_ext_table_init(struct ext_table * tbl, int init_capa)
 {
   tbl->size = 0;
@@ -139,11 +144,18 @@ void caml_ext_table_remove(struct ext_table * tbl, void * data)
   }
 }
 
-void caml_ext_table_free(struct ext_table * tbl, int free_entries)
+void caml_ext_table_clear(struct ext_table * tbl, int free_entries)
 {
   int i;
-  if (free_entries)
+  if (free_entries) {
     for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]);
+  }
+  tbl->size = 0;
+}
+
+void caml_ext_table_free(struct ext_table * tbl, int free_entries)
+{
+  caml_ext_table_clear(tbl, free_entries);
   caml_stat_free(tbl->contents);
 }
 

diff --git a/byterun/obj.c b/byterun/obj.c
index 5f1efdd4be902384973b68955e2aa7d35a71ba2e..861f5c1ef9bf620fad5cf6aee9d186e5da154f10 100644 (file)
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Operations on objects */
 
 #include <string.h>
@@ -26,6 +28,7 @@
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 #include "caml/prims.h"
+#include "spacetime.h"
 
 /* [size] is a value encoding a number of bytes */
 CAMLprim value caml_static_alloc(value size)
@@ -44,6 +47,7 @@ CAMLprim value caml_static_resize(value blk, value new_size)
   return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size));
 }
 
+/* unused since GPR#427 */
 CAMLprim value caml_obj_is_block(value arg)
 {
   return Val_bool(Is_block(arg));
@@ -85,6 +89,7 @@ CAMLprim value caml_obj_block(value tag, value size)
   return res;
 }
 
+/* Spacetime profiling assumes that this function is only called from OCaml. */
 CAMLprim value caml_obj_dup(value arg)
 {
   CAMLparam1 (arg);
@@ -99,7 +104,9 @@ CAMLprim value caml_obj_dup(value arg)
     res = caml_alloc(sz, tg);
     memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value));
   } else if (sz <= Max_young_wosize) {
-    res = caml_alloc_small(sz, tg);
+    uintnat profinfo;
+    Get_my_profinfo_with_cached_backtrace(profinfo, sz);
+    res = caml_alloc_small_with_my_or_given_profinfo(sz, tg, profinfo);
     for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i);
   } else {
     res = caml_alloc_shr(sz, tg);
@@ -154,7 +161,8 @@ CAMLprim value caml_obj_truncate (value v, value newsize)
      ref_table. */
   Field (v, new_wosize) =
     Make_header (Wosize_whsize (wosize-new_wosize), Abstract_tag, Caml_black);
-  Hd_val (v) = Make_header (new_wosize, tag, color);
+  Hd_val (v) =
+    Make_header_with_profinfo (new_wosize, tag, color, Profinfo_val(v));
   return Val_unit;
 }
 
@@ -260,3 +268,122 @@ CAMLprim value caml_fresh_oo_id (value v) {
 CAMLprim value caml_int_as_pointer (value n) {
   return n - 1;
 }
+
+/* Compute how many words in the heap are occupied by blocks accessible
+   from a given value */
+
+#define ENTRIES_PER_QUEUE_CHUNK 4096
+struct queue_chunk {
+  struct queue_chunk *next;
+  value entries[ENTRIES_PER_QUEUE_CHUNK];
+};
+
+
+CAMLprim value caml_obj_reachable_words(value v)
+{
+  static struct queue_chunk first_chunk;
+  struct queue_chunk *read_chunk, *write_chunk;
+  int write_pos, read_pos, i;
+
+  intnat size = 0;
+  header_t hd;
+  mlsize_t sz;
+
+  if (Is_long(v) || !Is_in_heap_or_young(v)) return Val_int(0);
+  if (Tag_hd(Hd_val(v)) == Infix_tag) v -= Infix_offset_hd(Hd_val(v));
+  hd = Hd_val(v);
+  sz = Wosize_hd(hd);
+
+  read_chunk = write_chunk = &first_chunk;
+  read_pos = 0;
+  write_pos = 1;
+  write_chunk->entries[0] = v | Colornum_hd(hd);
+  Hd_val(v) = Bluehd_hd(hd);
+
+  /* We maintain a queue of "interesting" blocks that have been seen.
+     An interesting block is a block in the heap which does not
+     represent an infix pointer. Infix pointers are normalized to the
+     beginning of their block.  Blocks in the static data area are excluded.
+
+     The function maintains a queue of block pointers.  Concretely,
+     the queue is stored as a linked list of chunks, each chunk
+     holding a number of pointers to interesting blocks.  Initially,
+     it contains only the "root" value.  The first chunk of the queue
+     is allocated statically.  More chunks can be allocated as needed
+     and released before this function exits.
+
+     When a block is inserted in the queue, it is marked as blue.
+     This mark is used to avoid a second visit of the same block.
+     The real color is stored in the last 2 bits of the pointer in the
+     queue.  (Same technique as in extern.c.)
+
+     Note: we make the assumption that there is no pointer
+     from the static data area to the heap.
+  */
+
+  /* First pass: mark accessible blocks and compute their total size */
+  while (read_pos != write_pos || read_chunk != write_chunk) {
+    /* Pop the next element from the queue */
+    if (read_pos == ENTRIES_PER_QUEUE_CHUNK) {
+      read_pos = 0;
+      read_chunk = read_chunk->next;
+    }
+    v = read_chunk->entries[read_pos++] & ~3;
+
+    hd = Hd_val(v);
+    sz = Wosize_hd(hd);
+
+    size += Whsize_wosize(sz);
+
+    if (Tag_hd(hd) < No_scan_tag) {
+      /* Push the interesting fields on the queue */
+      for (i = 0; i < sz; i++) {
+        value v2 = Field(v, i);
+        if (Is_block(v2) && Is_in_heap_or_young(v2)) {
+          if (Tag_hd(Hd_val(v2)) == Infix_tag){
+            v2 -= Infix_offset_hd(Hd_val(v2));
+          }
+          hd = Hd_val(v2);
+          if (Color_hd(hd) != Caml_blue) {
+            if (write_pos == ENTRIES_PER_QUEUE_CHUNK) {
+              struct queue_chunk *new_chunk =
+                malloc(sizeof(struct queue_chunk));
+              if (new_chunk == NULL) {
+                size = (-1);
+                goto release;
+              }
+              write_chunk->next = new_chunk;
+              write_pos = 0;
+              write_chunk = new_chunk;
+            }
+            write_chunk->entries[write_pos++] = v2 | Colornum_hd(hd);
+            Hd_val(v2) = Bluehd_hd(hd);
+          }
+        }
+      }
+    }
+  }
+
+  /* Second pass: restore colors and free extra queue chunks */
+ release:
+  read_pos = 0;
+  read_chunk = &first_chunk;
+  while (read_pos != write_pos || read_chunk != write_chunk) {
+    color_t colornum;
+    if (read_pos == ENTRIES_PER_QUEUE_CHUNK) {
+      struct queue_chunk *prev = read_chunk;
+      read_pos = 0;
+      read_chunk = read_chunk->next;
+      if (prev != &first_chunk) free(prev);
+    }
+    v = read_chunk->entries[read_pos++];
+    colornum = v & 3;
+    v &= ~3;
+    Hd_val(v) = Coloredhd_hd(Hd_val(v), colornum);
+  }
+  if (read_chunk != &first_chunk) free(read_chunk);
+
+  if (size < 0)
+    caml_raise_out_of_memory();
+  return Val_int(size);
+}

diff --git a/byterun/parsing.c b/byterun/parsing.c
index 89ca4c5ee71d015ae77710574591a33ac01ce574..ad1cc8cce653f6c88674341cba1dd891821fb69f 100644 (file)
--- a/byterun/parsing.c
+++ b/byterun/parsing.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The PDA automaton for parsers generated by camlyacc */
 
 #include <stdio.h>

diff --git a/byterun/printexc.c b/byterun/printexc.c
index ee7a591d9a3645a79195142409591a02656340b1..971f1724856f4321e4e434991076b3e75bd69a6e 100644 (file)
--- a/byterun/printexc.c
+++ b/byterun/printexc.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Print an uncaught exception and abort */
 
 #include <stdio.h>
@@ -141,5 +143,6 @@ void caml_fatal_uncaught_exception(value exn)
   else
     default_fatal_uncaught_exception(exn);
   /* Terminate the process */
-  exit(2);
+  CAML_SYS_EXIT(2);
+  exit(2); /* Second exit needed for the Noreturn flag */
 }

diff --git a/byterun/roots.c b/byterun/roots.c
index a1cba5e378a6a943e9ac6f351b9dd035591f603b..1445495a0d43a0b50d52839426aee35f9129c95a 100644 (file)
--- a/byterun/roots.c
+++ b/byterun/roots.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* To walk the memory roots for garbage collection */
 
 #include "caml/finalise.h"
@@ -55,7 +57,7 @@ void caml_oldify_local_roots (void)
   /* Global C roots */
   caml_scan_global_young_roots(&caml_oldify_one);
   /* Finalised values */
-  caml_final_do_young_roots (&caml_oldify_one);
+  caml_final_oldify_young_roots ();
   /* Hook */
   if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one);
 }
@@ -89,7 +91,7 @@ void caml_do_roots (scanning_action f, int do_globals)
   caml_scan_global_roots(f);
   CAML_INSTR_TIME (tmr, "major_roots/C");
   /* Finalised values */
-  caml_final_do_strong_roots (f);
+  caml_final_do_roots (f);
   CAML_INSTR_TIME (tmr, "major_roots/finalised");
   /* Hook */
   if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);

diff --git a/byterun/signals.c b/byterun/signals.c
index 5c4e2614e816fdd3350a90ca96fb41a0e018f97f..4763f7a9f8bf0260648ab975df4ba12ebbea30f7 100644 (file)
--- a/byterun/signals.c
+++ b/byterun/signals.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Signal handling, code common to the bytecode and native systems */
 
 #include <signal.h>
@@ -29,6 +31,10 @@
 #include "caml/signals_machdep.h"
 #include "caml/sys.h"
 
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#include "../asmrun/spacetime.h"
+#endif
+
 #ifndef NSIG
 #define NSIG 64
 #endif
@@ -133,6 +139,10 @@ static value caml_signal_handlers = 0;
 void caml_execute_signal(int signal_number, int in_signal_handler)
 {
   value res;
+  value handler;
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  void* saved_spacetime_trie_node_ptr;
+#endif
 #ifdef POSIX_SIGNALS
   sigset_t sigs;
   /* Block the signal before executing the handler, and record in sigs
@@ -141,9 +151,36 @@ void caml_execute_signal(int signal_number, int in_signal_handler)
   sigaddset(&sigs, signal_number);
   sigprocmask(SIG_BLOCK, &sigs, &sigs);
 #endif
-  res = caml_callback_exn(
-           Field(caml_signal_handlers, signal_number),
-           Val_int(caml_rev_convert_signal_number(signal_number)));
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  /* We record the signal handler's execution separately, in the same
+     trie used for finalisers. */
+  saved_spacetime_trie_node_ptr
+    = caml_spacetime_trie_node_ptr;
+  caml_spacetime_trie_node_ptr
+    = caml_spacetime_finaliser_trie_root;
+#endif
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  /* Handled action may have no associated handler, which we interpret
+     as meaning the signal should be handled by a call to exit.  This is
+     is used to allow spacetime profiles to be completed on interrupt */
+  if (caml_signal_handlers == 0) {
+    res = caml_sys_exit(Val_int(2));
+  } else {
+    handler = Field(caml_signal_handlers, signal_number);
+    if (!Is_block(handler)) {
+      res = caml_sys_exit(Val_int(2));
+    } else {
+#else
+  handler = Field(caml_signal_handlers, signal_number);
+#endif
+    res = caml_callback_exn(
+             handler,
+             Val_int(caml_rev_convert_signal_number(signal_number)));
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+    }
+  }
+  caml_spacetime_trie_node_ptr = saved_spacetime_trie_node_ptr;
+#endif
 #ifdef POSIX_SIGNALS
   if (! in_signal_handler) {
     /* Restore the original signal mask */
@@ -328,8 +365,23 @@ CAMLprim value caml_install_signal_handler(value signal_number, value action)
     res = Val_int(1);
     break;
   case 2:                       /* was Signal_handle */
+    #if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+      /* Handled action may have no associated handler
+         which we treat as Signal_default */
+      if (caml_signal_handlers == 0) {
+        res = Val_int(0);
+      } else {
+        if (!Is_block(Field(caml_signal_handlers, sig))) {
+          res = Val_int(0);
+        } else {
+          res = caml_alloc_small (1, 0);
+          Field(res, 0) = Field(caml_signal_handlers, sig);
+        }
+      }
+    #else
     res = caml_alloc_small (1, 0);
     Field(res, 0) = Field(caml_signal_handlers, sig);
+    #endif
     break;
   default:                      /* error in caml_set_signal_action */
     caml_sys_error(NO_ARG);

diff --git a/byterun/signals_byt.c b/byterun/signals_byt.c
index 38aebfd032ae398d87361d2d34d6dc787f848832..bdbcf7267e44877be25123bad8f8dc94f9790380 100644 (file)
--- a/byterun/signals_byt.c
+++ b/byterun/signals_byt.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Signal handling, code specific to the bytecode interpreter */
 
 #include <signal.h>

diff --git a/byterun/spacetime.c b/byterun/spacetime.c
new file mode 100644 (file)
index 0000000..fd8b4fd
--- /dev/null
+++ b/byterun/spacetime.c
@@ -0,0 +1,40 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2013--2016, Jane Street Group, LLC                         */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <assert.h>
+#include "caml/fail.h"
+#include "caml/mlvalues.h"
+
+int ensure_spacetime_dot_o_is_included = 42;
+
+CAMLprim value caml_spacetime_only_works_for_native_code(value foo, ...)
+{
+  caml_failwith("Spacetime profiling only works for native code");
+  assert(0);  /* unreachable */
+}
+
+uintnat caml_spacetime_my_profinfo (void)
+{
+  return 0;
+}
+
+CAMLprim value caml_spacetime_enabled (value v_unit)
+{
+  return Val_false;  /* running in bytecode */
+}
+
+CAMLprim value caml_register_channel_for_spacetime (value v_channel)
+{
+  return Val_unit;
+}

diff --git a/byterun/spacetime.h b/byterun/spacetime.h
new file mode 100644 (file)
index 0000000..ffb006b
--- /dev/null
+++ b/byterun/spacetime.h
@@ -0,0 +1,21 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*            Mark Shinwell and Leo White, Jane Street Europe             */
+/*                                                                        */
+/*   Copyright 2016, Jane Street Group, LLC                               */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_SPACETIME_H
+#define CAML_SPACETIME_H
+
+#define Get_my_profinfo_with_cached_backtrace(profinfo, size) \
+  profinfo = (uintnat) 0;
+
+#endif

diff --git a/byterun/stacks.c b/byterun/stacks.c
index cb96d2d7fdfaa9527ef58f61bb4b94e26035c2ac..5e7c9a5f78764d601d1dc83541d70f92d3bbc7ff 100644 (file)
--- a/byterun/stacks.c
+++ b/byterun/stacks.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* To initialize and resize the stacks */
 
 #include <string.h>

diff --git a/byterun/startup.c b/byterun/startup.c
index 0d2c1945187cf8847b68757b9ab16039aab1d428..ac19ee3f732759ff28864c9f3543ec744e34e98a 100644 (file)
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Start-up code */
 
 #include <stdio.h>
@@ -259,13 +261,15 @@ extern void caml_init_ieee_floats (void);
 extern void caml_signal_thread(void * lpParam);
 #endif
 
-#ifdef _MSC_VER
+#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
 
 /* PR 4887: avoid crash box of windows runtime on some system calls */
 extern void caml_install_invalid_parameter_handler();
 
 #endif
 
+extern int ensure_spacetime_dot_o_is_included;
+
 /* Main entry point when loading code from a file */
 
 CAMLexport void caml_main(char **argv)
@@ -278,10 +282,12 @@ CAMLexport void caml_main(char **argv)
   char * exe_name;
   static char proc_self_exe[256];
 
+  ensure_spacetime_dot_o_is_included++;
+
   /* Machine-dependent initialization of the floating-point hardware
      so that it behaves as much as possible as specified in IEEE */
   caml_init_ieee_floats();
-#ifdef _MSC_VER
+#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
   caml_install_invalid_parameter_handler();
 #endif
   caml_init_custom_operations();
@@ -397,7 +403,7 @@ CAMLexport void caml_startup_code(
   static char proc_self_exe[256];
 
   caml_init_ieee_floats();
-#ifdef _MSC_VER
+#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
   caml_install_invalid_parameter_handler();
 #endif
   caml_init_custom_operations();

diff --git a/byterun/startup_aux.c b/byterun/startup_aux.c
index 714e486afe52a217ef23eacd826462176a450973..109f71c3863deddabd3993058ea7e716bd7bc061 100644 (file)
--- a/byterun/startup_aux.c
+++ b/byterun/startup_aux.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Some runtime initialization functions that are common to bytecode
    and native code. */
 
@@ -28,7 +30,13 @@ CAMLexport header_t caml_atom_table[256];
 void caml_init_atom_table(void)
 {
   int i;
-  for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white);
+  for(i = 0; i < 256; i++) {
+#ifdef NATIVE_CODE
+    caml_atom_table[i] = Make_header_allocated_here(0, i, Caml_white);
+#else
+    caml_atom_table[i] = Make_header(0, i, Caml_white);
+#endif
+  }
   if (caml_page_table_add(In_static_data,
                           caml_atom_table, caml_atom_table + 256) != 0) {
     caml_fatal_error("Fatal error: not enough memory for initial page table");

diff --git a/byterun/str.c b/byterun/str.c
index d8d9a74e9143bf7890fa8b8c6d0babb915320ca4..38a472e7fa35c0611d254df3a347414d7ed670dc 100644 (file)
--- a/byterun/str.c
+++ b/byterun/str.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Operations on strings */
 
 #include <string.h>
@@ -42,12 +44,20 @@ CAMLprim value caml_ml_string_length(value s)
   return Val_long(temp - Byte (s, temp));
 }
 
+CAMLprim value caml_ml_bytes_length(value s)
+{
+  return caml_ml_string_length(s);
+}
+
 CAMLexport int caml_string_is_c_safe (value s)
 {
   return strlen(String_val(s)) == caml_string_length(s);
 }
 
-/* [len] is a value that represents a number of bytes (chars) */
+/**
+ * [caml_create_string] is deprecated,
+ * use [caml_create_bytes] instead
+ */
 CAMLprim value caml_create_string(value len)
 {
   mlsize_t size = Long_val(len);
@@ -57,6 +67,18 @@ CAMLprim value caml_create_string(value len)
   return caml_alloc_string(size);
 }
 
+/* [len] is a value that represents a number of bytes (chars) */
+CAMLprim value caml_create_bytes(value len)
+{
+  mlsize_t size = Long_val(len);
+  if (size > Bsize_wsize (Max_wosize) - 1){
+    caml_invalid_argument("Bytes.create");
+  }
+  return caml_alloc_string(size);
+}
+
+
+
 CAMLprim value caml_string_get(value str, value index)
 {
   intnat idx = Long_val(index);
@@ -64,7 +86,12 @@ CAMLprim value caml_string_get(value str, value index)
   return Val_int(Byte_u(str, idx));
 }
 
-CAMLprim value caml_string_set(value str, value index, value newval)
+CAMLprim value caml_bytes_get(value str, value index)
+{
+  return caml_string_get(str, index);
+}
+
+CAMLprim value caml_bytes_set(value str, value index, value newval)
 {
   intnat idx = Long_val(index);
   if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error();
@@ -72,6 +99,16 @@ CAMLprim value caml_string_set(value str, value index, value newval)
   return Val_unit;
 }
 
+/**
+ * [caml_string_set] is deprecated,
+ * use [caml_bytes_set] instead
+ */
+CAMLprim value caml_string_set(value str, value index, value newval)
+{
+  return caml_bytes_set(str,index,newval);
+}
+
+
 CAMLprim value caml_string_get16(value str, value index)
 {
   intnat res;
@@ -229,11 +266,21 @@ CAMLprim value caml_string_equal(value s1, value s2)
   return Val_true;
 }
 
+CAMLprim value caml_bytes_equal(value s1, value s2)
+{
+  return caml_string_equal(s1,s2);
+}
+
 CAMLprim value caml_string_notequal(value s1, value s2)
 {
   return Val_not(caml_string_equal(s1, s2));
 }
 
+CAMLprim value caml_bytes_notequal(value s1, value s2)
+{
+  return caml_string_notequal(s1,s2);
+}
+
 CAMLprim value caml_string_compare(value s1, value s2)
 {
   mlsize_t len1, len2;
@@ -250,39 +297,80 @@ CAMLprim value caml_string_compare(value s1, value s2)
   return Val_int(0);
 }
 
+CAMLprim value caml_bytes_compare(value s1, value s2)
+{
+  return caml_string_compare(s1,s2);
+}
+
 CAMLprim value caml_string_lessthan(value s1, value s2)
 {
   return caml_string_compare(s1, s2) < Val_int(0) ? Val_true : Val_false;
 }
 
+CAMLprim value caml_bytes_lessthan(value s1, value s2)
+{
+  return caml_string_lessthan(s1,s2);
+}
+
+
 CAMLprim value caml_string_lessequal(value s1, value s2)
 {
   return caml_string_compare(s1, s2) <= Val_int(0) ? Val_true : Val_false;
 }
 
+CAMLprim value caml_bytes_lessequal(value s1, value s2)
+{
+  return caml_string_lessequal(s1,s2);
+}
+
+
 CAMLprim value caml_string_greaterthan(value s1, value s2)
 {
   return caml_string_compare(s1, s2) > Val_int(0) ? Val_true : Val_false;
 }
 
+CAMLprim value caml_bytes_greaterthan(value s1, value s2)
+{
+  return caml_string_greaterthan(s1,s2);
+}
+
 CAMLprim value caml_string_greaterequal(value s1, value s2)
 {
   return caml_string_compare(s1, s2) >= Val_int(0) ? Val_true : Val_false;
 }
 
-CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2,
+CAMLprim value caml_bytes_greaterequal(value s1, value s2)
+{
+  return caml_string_greaterequal(s1,s2);
+}
+
+CAMLprim value caml_blit_bytes(value s1, value ofs1, value s2, value ofs2,
                                 value n)
 {
   memmove(&Byte(s2, Long_val(ofs2)), &Byte(s1, Long_val(ofs1)), Long_val(n));
   return Val_unit;
 }
 
-CAMLprim value caml_fill_string(value s, value offset, value len, value init)
+CAMLprim value caml_blit_string(value s1, value ofs1, value s2, value ofs2,
+                                value n)
+{
+  return caml_blit_bytes (s1, ofs1, s2, ofs2, n);
+}
+
+CAMLprim value caml_fill_bytes(value s, value offset, value len, value init)
 {
   memset(&Byte(s, Long_val(offset)), Int_val(init), Long_val(len));
   return Val_unit;
 }
 
+/**
+ * [caml_fill_string] is deprecated, use [caml_fill_bytes] instead
+ */
+CAMLprim value caml_fill_string(value s, value offset, value len, value init)
+{
+  return caml_fill_bytes (s, offset, len, init);
+}
+
 CAMLprim value caml_bitvect_test(value bv, value n)
 {
   intnat pos = Long_val(n);

diff --git a/byterun/sys.c b/byterun/sys.c
index 0fbc382e21d9eca0af668eddc3a8abb979ac9d99..78ec5fe7c8decd6bee4e5a8c432144d70536a99c 100644 (file)
--- a/byterun/sys.c
+++ b/byterun/sys.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Basic system calls */
 
 #include <errno.h>
@@ -55,6 +57,7 @@
 #include "caml/signals.h"
 #include "caml/stacks.h"
 #include "caml/sys.h"
+#include "caml/version.h"
 
 static char * error_message(void)
 {
@@ -108,8 +111,10 @@ static void caml_sys_check_path(value name)
   }
 }
 
-CAMLprim value caml_sys_exit(value retcode)
+CAMLprim value caml_sys_exit(value retcode_v)
 {
+  int retcode = Int_val(retcode_v);
+
   if ((caml_verb_gc & 0x400) != 0) {
     /* cf caml_gc_counters */
     double minwords = caml_stat_minor_words
@@ -139,7 +144,7 @@ CAMLprim value caml_sys_exit(value retcode)
   caml_debugger(PROGRAM_EXIT);
 #endif
   CAML_INSTR_ATEXIT ();
-  exit(Int_val(retcode));
+  CAML_SYS_EXIT(retcode);
   return Val_unit;
 }
 
@@ -174,7 +179,7 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm)
   perm = Int_val(vperm);
   /* open on a named FIFO can block (PR#1533) */
   caml_enter_blocking_section();
-  fd = open(p, flags, perm);
+  fd = CAML_SYS_OPEN(p, flags, perm);
   /* fcntl on a fd can block (PR#5069)*/
 #if defined(F_SETFD) && defined(FD_CLOEXEC)
   if (fd != -1)
@@ -186,10 +191,11 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm)
   CAMLreturn(Val_long(fd));
 }
 
-CAMLprim value caml_sys_close(value fd)
+CAMLprim value caml_sys_close(value fd_v)
 {
+  int fd = Int_val(fd_v);
   caml_enter_blocking_section();
-  close(Int_val(fd));
+  CAML_SYS_CLOSE(fd);
   caml_leave_blocking_section();
   return Val_unit;
 }
@@ -210,7 +216,7 @@ CAMLprim value caml_sys_file_exists(value name)
 #ifdef _WIN32
   ret = _stati64(p, &st);
 #else
-  ret = stat(p, &st);
+  ret = CAML_SYS_STAT(p, &st);
 #endif
   caml_leave_blocking_section();
   caml_stat_free(p);
@@ -235,7 +241,7 @@ CAMLprim value caml_sys_is_directory(value name)
 #ifdef _WIN32
   ret = _stati64(p, &st);
 #else
-  ret = stat(p, &st);
+  ret = CAML_SYS_STAT(p, &st);
 #endif
   caml_leave_blocking_section();
   caml_stat_free(p);
@@ -256,7 +262,7 @@ CAMLprim value caml_sys_remove(value name)
   caml_sys_check_path(name);
   p = caml_strdup(String_val(name));
   caml_enter_blocking_section();
-  ret = unlink(p);
+  ret = CAML_SYS_UNLINK(p);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret != 0) caml_sys_error(name);
@@ -273,7 +279,7 @@ CAMLprim value caml_sys_rename(value oldname, value newname)
   p_old = caml_strdup(String_val(oldname));
   p_new = caml_strdup(String_val(newname));
   caml_enter_blocking_section();
-  ret = rename(p_old, p_new);
+  ret = CAML_SYS_RENAME(p_old, p_new);
   caml_leave_blocking_section();
   caml_stat_free(p_new);
   caml_stat_free(p_old);
@@ -290,7 +296,7 @@ CAMLprim value caml_sys_chdir(value dirname)
   caml_sys_check_path(dirname);
   p = caml_strdup(String_val(dirname));
   caml_enter_blocking_section();
-  ret = chdir(p);
+  ret = CAML_SYS_CHDIR(p);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret != 0) caml_sys_error(dirname);
@@ -313,7 +319,7 @@ CAMLprim value caml_sys_getenv(value var)
   char * res;
 
   if (! caml_string_is_c_safe(var)) caml_raise_not_found();
-  res = getenv(String_val(var));
+  res = CAML_SYS_GETENV(String_val(var));
   if (res == 0) caml_raise_not_found();
   return caml_copy_string(res);
 }
@@ -335,6 +341,9 @@ CAMLprim value caml_sys_get_argv(value unit)
 
 void caml_sys_init(char * exe_name, char **argv)
 {
+#ifdef CAML_WITH_CPLUGINS
+  caml_cplugins_init(exe_name, argv);
+#endif
   caml_exe_name = exe_name;
   caml_main_argv = argv;
 }
@@ -362,7 +371,7 @@ CAMLprim value caml_sys_system_command(value command)
   }
   buf = caml_strdup(String_val(command));
   caml_enter_blocking_section ();
-  status = system(buf);
+  status = CAML_SYS_SYSTEM(buf);
   caml_leave_blocking_section ();
   caml_stat_free(buf);
   if (status == -1) caml_sys_error(command);
@@ -493,6 +502,10 @@ CAMLprim value caml_sys_const_ostype_cygwin(value unit)
   return Val_bool(0 == strcmp(OCAML_OS_TYPE,"Cygwin"));
 }
 
+CAMLprim value caml_sys_const_backend_type(value unit)
+{
+  return Val_int(1); /* Bytecode backed */
+}
 CAMLprim value caml_sys_get_config(value unit)
 {
   CAMLparam0 ();   /* unit is unused */
@@ -522,7 +535,7 @@ CAMLprim value caml_sys_read_directory(value path)
   caml_ext_table_init(&tbl, 50);
   p = caml_strdup(String_val(path));
   caml_enter_blocking_section();
-  ret = caml_read_directory(p, &tbl);
+  ret = CAML_SYS_READ_DIRECTORY(p, &tbl);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret == -1){
@@ -552,3 +565,73 @@ CAMLprim value caml_sys_isatty(value chan)
 
   return ret;
 }
+
+/* Load dynamic plugins indicated in the CAML_CPLUGINS environment
+   variable. These plugins can be used to set currently existing
+   hooks, such as GC hooks and system calls tracing (see misc.h).
+ */
+
+#ifdef CAML_WITH_CPLUGINS
+
+value (*caml_cplugins_prim)(int,value,value,value) = NULL;
+
+#define DLL_EXECUTABLE 1
+#define DLL_NOT_GLOBAL 0
+
+static struct cplugin_context cplugin_context;
+
+void caml_load_plugin(char *plugin)
+{
+  void* dll_handle = NULL;
+
+  dll_handle = caml_dlopen(plugin, DLL_EXECUTABLE, DLL_NOT_GLOBAL);
+  if( dll_handle != NULL ){
+   void (* dll_init)(struct cplugin_context*) =
+     caml_dlsym(dll_handle, "caml_cplugin_init");
+   if( dll_init != NULL ){
+     cplugin_context.plugin=plugin;
+     dll_init(&cplugin_context);
+   } else {
+     caml_dlclose(dll_handle);
+   }
+  } else {
+   fprintf(stderr, "Cannot load C plugin %s\nReason: %s\n",
+          plugin, caml_dlerror());
+  }
+}
+
+void caml_cplugins_load(char *env_variable)
+{
+  char *plugins = getenv(env_variable);
+  if(plugins != NULL){
+    char* curs = plugins;
+    while(*curs != 0){
+        if(*curs == ','){
+          if(curs > plugins){
+            *curs = 0;
+            caml_load_plugin(plugins);
+          }
+          plugins = curs+1;
+        }
+        curs++;
+    }
+    if(curs > plugins) caml_load_plugin(plugins);
+  }
+}
+
+void caml_cplugins_init(char * exe_name, char **argv)
+{
+  cplugin_context.api_version = CAML_CPLUGIN_CONTEXT_API;
+  cplugin_context.prims_bitmap = CAML_CPLUGINS_PRIMS_BITMAP;
+  cplugin_context.exe_name = exe_name;
+  cplugin_context.argv = argv;
+  cplugin_context.ocaml_version = OCAML_VERSION_STRING;
+  caml_cplugins_load("CAML_CPLUGINS");
+#ifdef NATIVE_CODE
+  caml_cplugins_load("CAML_NATIVE_CPLUGINS");
+#else
+  caml_cplugins_load("CAML_BYTE_CPLUGINS");
+#endif
+}
+
+#endif /* CAML_WITH_CPLUGINS */

diff --git a/byterun/terminfo.c b/byterun/terminfo.c
index 41257328819137cde6ae1e57a59217f902e0f5f8..05ec87d316f4ac1bd3bb35e78787257106155311 100644 (file)
--- a/byterun/terminfo.c
+++ b/byterun/terminfo.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Read and output terminal commands */
 
 #include "caml/config.h"
@@ -74,7 +76,7 @@ CAMLprim value caml_terminfo_setup (value vchan)
 
 static int terminfo_putc (int c)
 {
-  putch (chan, c);
+  caml_putch (chan, c);
   return c;
 }
 

diff --git a/byterun/unix.c b/byterun/unix.c
index d3627733d07f8587f6149d17b04e24e18d2de3a7..150af2b2e167fa5f52c7e0c7dbba1da2bd2c43ce 100644 (file)
--- a/byterun/unix.c
+++ b/byterun/unix.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Unix-specific stuff */
 
 #define _GNU_SOURCE
@@ -47,6 +49,7 @@
 #include "caml/osdeps.h"
 #include "caml/signals.h"
 #include "caml/sys.h"
+#include "caml/io.h"
 
 #ifndef S_ISREG
 #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
@@ -78,9 +81,17 @@ int caml_write_fd(int fd, int flags, void * buf, int n)
 {
   int retcode;
  again:
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  if (flags & CHANNEL_FLAG_BLOCKING_WRITE) {
+    retcode = write(fd, buf, n);
+  } else {
+#endif
   caml_enter_blocking_section();
   retcode = write(fd, buf, n);
   caml_leave_blocking_section();
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  }
+#endif
   if (retcode == -1) {
     if (errno == EINTR) goto again;
     if ((errno == EAGAIN || errno == EWOULDBLOCK) && n > 1) {
@@ -322,7 +333,7 @@ char * caml_dlerror(void)
    the directory named [dirname].  No entries are added for [.] and [..].
    Return 0 on success, -1 on error; set errno in the case of error. */
 
-int caml_read_directory(char * dirname, struct ext_table * contents)
+CAMLexport int caml_read_directory(char * dirname, struct ext_table * contents)
 {
   DIR * d;
 #ifdef HAS_DIRENT

diff --git a/byterun/weak.c b/byterun/weak.c
index 39806cedaa16249bad87aece77c2eca64f6c5f3a..308d153c8eb6640bb5a62b17f9bc3aaf8aa87cd1 100644 (file)
--- a/byterun/weak.c
+++ b/byterun/weak.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Operations on weak arrays and ephemerons (named ephe here)*/
 
 #include <string.h>

diff --git a/byterun/win32.c b/byterun/win32.c
index c7865e66d12d598721f28dd77751dd3207fb2794..59d13000e279e38deb5bb99ee4ab2fcb4c78c09c 100644 (file)
--- a/byterun/win32.c
+++ b/byterun/win32.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Win32-specific stuff */
 
 #define WIN32_LEAN_AND_MEAN
@@ -49,6 +51,12 @@
 #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
 #endif
 
+/* Very old Microsoft headers don't include intptr_t */
+#if defined(_MSC_VER) && !defined(_UINTPTR_T_DEFINED)
+typedef unsigned int uintptr_t;
+#define _UINTPTR_T_DEFINED
+#endif
+
 CAMLnoreturn_start
 static void caml_win32_sys_error (int errnum)
 CAMLnoreturn_end;
@@ -97,9 +105,17 @@ int caml_write_fd(int fd, int flags, void * buf, int n)
 {
   int retcode;
   if ((flags & CHANNEL_FLAG_FROM_SOCKET) == 0) {
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  if (flags & CHANNEL_FLAG_BLOCKING_WRITE) {
+    retcode = write(fd, buf, n);
+  } else {
+#endif
     caml_enter_blocking_section();
     retcode = write(fd, buf, n);
     caml_leave_blocking_section();
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  }
+#endif
     if (retcode == -1) caml_sys_io_error(NO_ARG);
   } else {
     caml_enter_blocking_section();
@@ -579,7 +595,7 @@ int caml_win32_random_seed (intnat data[16])
 }
 
 
-#ifdef _MSC_VER
+#if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
 
 static void invalid_parameter_handler(const wchar_t* expression,
    const wchar_t* function,
@@ -612,6 +628,26 @@ int caml_executable_name(char * name, int name_len)
 
 /* snprintf emulation */
 
+#ifdef LACKS_VSCPRINTF
+/* No _vscprintf until Visual Studio .NET 2002 and sadly no version number
+   in the CRT headers until Visual Studio 2005 so forced to predicate this
+   on the compiler version instead */
+int _vscprintf(const char * format, va_list args)
+{
+  int n;
+  int sz = 5;
+  char* buf = (char*)malloc(sz);
+  n = _vsnprintf(buf, sz, format, args);
+  while (n < 0 || n > sz) {
+    sz += 512;
+    buf = (char*)realloc(buf, sz);
+    n = _vsnprintf(buf, sz, format, args);
+  }
+  free(buf);
+  return n;
+}
+#endif
+
 #if defined(_WIN32) && !defined(_UCRT)
 int caml_snprintf(char * buf, size_t size, const char * format, ...)
 {

diff --git a/config/Makefile-templ b/config/Makefile-templ
index 6b8231ebbef4702c1060479bbf7943d5347c770e..1cd797eb26c728fecf271d63163eafe1ce064d54 100644 (file)
--- a/config/Makefile-templ
+++ b/config/Makefile-templ
@@ -33,9 +33,9 @@ MANEXT=1
 ### Do #! scripts work on your system?
 ### Beware: on some systems (e.g. SunOS 4), this will work only if
 ### the string "#!$(BINDIR)/ocamlrun" is less than 32 characters long.
-### In doubt, set SHARPBANGSCRIPTS to false.
-SHARPBANGSCRIPTS=true
-#SHARPBANGSCRIPTS=false
+### In doubt, set HASHBANGSCRIPTS to false.
+HASHBANGSCRIPTS=true
+#HASHBANGSCRIPTS=false
 
 ########## Configuration for the bytecode compiler
 

diff --git a/config/Makefile.mingw b/config/Makefile.mingw
index 527e99151d18e3d454f0c1f3a426926a9694664e..f2d041168765143df4a66a47e7e03ac849469403 100644 (file)
--- a/config/Makefile.mingw
+++ b/config/Makefile.mingw
@@ -61,7 +61,7 @@ EXT_OBJ=.$(O)
 EXT_LIB=.$(A)
 EXT_ASM=.$(S)
 MANEXT=1
-SHARPBANGSCRIPTS=false
+HASHBANGSCRIPTS=false
 PTHREAD_LINK=
 X11_INCLUDES=
 X11_LINK=
@@ -86,6 +86,11 @@ ASM_CFI_SUPPORTED=false
 UNIXLIB=win32unix
 GRAPHLIB=win32graph
 FLAMBDA=false
+WITH_SPACETIME=false
+LIBUNWIND_AVAILABLE=false
+LIBUNWIND_LINK_FLAGS=
+PROFINFO_WIDTH=26
+SAFE_STRING=false
 
 ########## Configuration for the bytecode compiler
 
@@ -95,6 +100,12 @@ BYTECC=$(TOOLPREF)gcc
 ### Additional compile-time options for $(BYTECC).  (For static linking.)
 BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
 
+### Additional compile-time options for $(BYTECC).  (For debug version.)
+BYTECCDBGCOMPOPTS=-g
+
+### Flag to use to rename object files.  (for debug version.)
+NAME_OBJ_FLAG=-o
+
 ### Additional link-time options for $(BYTECC).  (For static linking.)
 BYTECCLINKOPTS=
 

diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64
index 79ff7943a11c485b16f69992b560092885bd5195..14c575b3c31b800a53d27d071fc694b8c1235fab 100644 (file)
--- a/config/Makefile.mingw64
+++ b/config/Makefile.mingw64
@@ -61,7 +61,7 @@ EXT_OBJ=.$(O)
 EXT_LIB=.$(A)
 EXT_ASM=.$(S)
 MANEXT=1
-SHARPBANGSCRIPTS=false
+HASHBANGSCRIPTS=false
 PTHREAD_LINK=
 X11_INCLUDES=
 X11_LINK=
@@ -86,6 +86,11 @@ ASM_CFI_SUPPORTED=false
 UNIXLIB=win32unix
 GRAPHLIB=win32graph
 FLAMBDA=false
+WITH_SPACETIME=false
+LIBUNWIND_AVAILABLE=false
+LIBUNWIND_LINK_FLAGS=
+PROFINFO_WIDTH=26
+SAFE_STRING=false
 
 ########## Configuration for the bytecode compiler
 
@@ -95,6 +100,12 @@ BYTECC=$(TOOLPREF)gcc
 ### Additional compile-time options for $(BYTECC).  (For static linking.)
 BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
 
+### Additional compile-time options for $(BYTECC).  (For debug version.)
+BYTECCDBGCOMPOPTS=-g
+
+### Flag to use to rename object files.  (for debug version.)
+NAME_OBJ_FLAG=-o
+
 ### Additional link-time options for $(BYTECC).  (For static linking.)
 BYTECCLINKOPTS=
 

diff --git a/config/Makefile.msvc b/config/Makefile.msvc
index 20ddaf95a3127171079466ed6db43923536b0f4c..5ffd6c0ecf3e47f4251b530a98e4ea6a5b173772 100644 (file)
--- a/config/Makefile.msvc
+++ b/config/Makefile.msvc
@@ -56,7 +56,7 @@ EXT_OBJ=.$(O)
 EXT_LIB=.$(A)
 EXT_ASM=.$(S)
 MANEXT=1
-SHARPBANGSCRIPTS=false
+HASHBANGSCRIPTS=false
 PTHREAD_LINK=
 X11_INCLUDES=
 X11_LINK=
@@ -80,6 +80,11 @@ ASM_CFI_SUPPORTED=false
 UNIXLIB=win32unix
 GRAPHLIB=win32graph
 FLAMBDA=false
+WITH_SPACETIME=false
+LIBUNWIND_AVAILABLE=false
+LIBUNWIND_LINK_FLAGS=
+PROFINFO_WIDTH=26
+SAFE_STRING=false
 
 ########## Configuration for the bytecode compiler
 
@@ -89,6 +94,12 @@ BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE
 ### Additional compile-time options for $(BYTECC).  (For static linking.)
 BYTECCCOMPOPTS=-O2 -Gy- -MD
 
+### Additional compile-time options for $(BYTECC).  (For debug version.)
+BYTECCDBGCOMPOPTS=-Zi
+
+### Flag to use to rename object files.  (for debug version.)
+NAME_OBJ_FLAG=-Fo
+
 ### Additional link-time options for $(BYTECC).  (For static linking.)
 BYTECCLINKOPTS=
 

diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64
index 0758aa7c08356f1de3caa1abd003eba284e0d767..720b2e14032ee985ebbae22c143144caff979f34 100644 (file)
--- a/config/Makefile.msvc64
+++ b/config/Makefile.msvc64
@@ -56,7 +56,7 @@ EXT_OBJ=.$(O)
 EXT_LIB=.$(A)
 EXT_ASM=.$(S)
 MANEXT=1
-SHARPBANGSCRIPTS=false
+HASHBANGSCRIPTS=false
 PTHREAD_LINK=
 X11_INCLUDES=
 X11_LINK=
@@ -79,6 +79,11 @@ ASM_CFI_SUPPORTED=false
 UNIXLIB=win32unix
 GRAPHLIB=win32graph
 FLAMBDA=false
+WITH_SPACETIME=false
+LIBUNWIND_AVAILABLE=false
+LIBUNWIND_LINK_FLAGS=
+PROFINFO_WIDTH=26
+SAFE_STRING=false
 
 ########## Configuration for the bytecode compiler
 
@@ -89,7 +94,10 @@ BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE
 BYTECCCOMPOPTS=-O2 -Gy- -MD
 
 ### Additional compile-time options for $(BYTECC).  (For debug version.)
-BYTECCDBGCOMPOPTS=-DDEBUG -Zi -W3 -Wp64
+BYTECCDBGCOMPOPTS=-Zi
+
+### Flag to use to rename object files.  (for debug version.)
+NAME_OBJ_FLAG=-Fo
 
 ### Additional link-time options for $(BYTECC).  (For static linking.)
 BYTECCLINKOPTS=

diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot
index 1ba464ca9b2cc20a30c7a80b7c779591653b2445..8b6c690396c4df36a21b004330a656e63aaee982 100755 (executable)
--- a/config/auto-aux/hasgot
+++ b/config/auto-aux/hasgot
@@ -24,6 +24,7 @@ while : ; do
   case "$1" in
     -i) echo "#include <$2>" >> hasgot.c; shift;;
     -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;;
+    -Xl) libs="$libs $2"; shift;;
     -l*|-L*|-F*) libs="$libs $1";;
     -framework) libs="$libs $1 $2"; shift;;
     -*) opts="$opts $1";;

diff --git a/config/auto-aux/hashbang b/config/auto-aux/hashbang
new file mode 100755 (executable)
index 0000000..eb447ba
--- /dev/null
+++ b/config/auto-aux/hashbang
@@ -0,0 +1,2 @@
+#! /bin/cat
+exit 1

diff --git a/config/auto-aux/hashbang2 b/config/auto-aux/hashbang2
new file mode 100755 (executable)
index 0000000..3753096
--- /dev/null
+++ b/config/auto-aux/hashbang2
@@ -0,0 +1,2 @@
+#! /usr/bin/cat
+exit 1

diff --git a/config/auto-aux/sharpbang b/config/auto-aux/sharpbang
deleted file mode 100755 (executable)
index eb447ba..0000000
--- a/config/auto-aux/sharpbang
+++ /dev/null
@@ -1,2 +0,0 @@
-#! /bin/cat
-exit 1

diff --git a/config/auto-aux/sharpbang2 b/config/auto-aux/sharpbang2
deleted file mode 100755 (executable)
index 3753096..0000000
--- a/config/auto-aux/sharpbang2
+++ /dev/null
@@ -1,2 +0,0 @@
-#! /usr/bin/cat
-exit 1

diff --git a/config/m-nt.h b/config/m-nt.h
index 900e3f09f7f2e82915076f364e301f97f1447c12..28a1815ab7a0dff1fd0083c3d9de4b470dcd7c3b 100644 (file)
--- a/config/m-nt.h
+++ b/config/m-nt.h
@@ -47,3 +47,5 @@
 #endif
 
 #undef NONSTANDARD_DIV_MOD
+
+#define PROFINFO_WIDTH 26

diff --git a/config/s-nt.h b/config/s-nt.h
index 79a716f2797248ec9828b926573aee5b6961a3d9..8c28dc5ef32a81bcf903be3eaa5aed68e0905067 100644 (file)
--- a/config/s-nt.h
+++ b/config/s-nt.h
@@ -34,3 +34,7 @@
 #define HAS_IPV6
 #define HAS_NICE
 #define SUPPORT_DYNAMIC_LINKING
+#if defined(_MSC_VER) && _MSC_VER < 1300
+#define LACKS_SANE_NAN
+#define LACKS_VSCPRINTF
+#endif

diff --git a/config/s-templ.h b/config/s-templ.h
index 567f10b1d330bdab5efd6d3eb0f46eabaef6f2cf..9ab980b21ee357d560dcd856d32a59e64a046b05 100644 (file)
--- a/config/s-templ.h
+++ b/config/s-templ.h
@@ -130,6 +130,9 @@
 /* Define HAS_SYS_SELECT_H if /usr/include/sys/select.h exists
    and should be included before using select(). */
 
+#define HAS_NANOSLEEP
+/* Define HAS_NANOSLEEP if you have nanosleep(). */
+
 #define HAS_SYMLINK
 
 /* Define HAS_SYMLINK if you have symlink() and readlink() and lstat(). */

diff --git a/configure b/configure
index 0bb2d35f9d1592e08ce45990724a228a4073f970..f43893a4e366e7556d3a2ee050825f2dfa43f076 100755 (executable)
--- a/configure
+++ b/configure
@@ -36,6 +36,10 @@ mathlib='-lm'
 dllib=''
 x11_include_dir=''
 x11_lib_dir=''
+libunwind_include_dir=''
+libunwind_lib_dir=''
+libunwind_available=false
+disable_libunwind=false
 graph_wanted=yes
 pthread_wanted=yes
 dl_defs=''
@@ -48,12 +52,16 @@ partialld="ld -r"
 with_debugger=ocamldebugger
 with_ocamldoc=ocamldoc
 with_frame_pointers=false
+with_spacetime=false
 no_naked_pointers=false
 native_compiler=true
 TOOLPREF=""
 with_cfi=true
 flambda=false
+safe_string=false
 max_testsuite_dir_retries=0
+with_cplugins=true
+with_fpic=false
 
 # Try to turn internationalization off, can cause config.guess to malfunction!
 unset LANG
@@ -114,6 +122,16 @@ while : ; do
             manext=1;;
         esac
         shift;;
+    -libunwinddir|--libunwinddir)
+        libunwind_include_dir=$2/include;
+        libunwind_lib_dir=$2/lib;
+        shift;;
+    -libunwindlib|--libunwindlib)
+        libunwind_lib_dir=$2; shift;;
+    -libunwindinclude|--libunwindinclude)
+        libunwind_include_dir=$2; shift;;
+    -disable-libunwind|--disable-libunwind)
+        disable_libunwind=true;;
     -host*|--host*)
         host_type=$2; shift;;
     -target*|--target*)
@@ -161,12 +179,20 @@ while : ; do
         with_frame_pointers=true;;
     -no-naked-pointers|--no-naked-pointers)
         no_naked_pointers=true;;
+    -spacetime|--spacetime)
+        with_spacetime=true;;
     -no-cfi|--no-cfi)
         with_cfi=false;;
-    -no-native-compiler)
+    -no-native-compiler|--no-native-compiler)
         native_compiler=false;;
-    -flambda)
+    -flambda|--flambda)
         flambda=true;;
+    -no-cplugins|--no-cplugins)
+        with_cplugins=false;;
+    -fPIC|--fPIC)
+        with_fpic=true;;
+    -safe-string|--safe-string)
+        safe_string=true;;
     *) if echo "$1" | grep -q -e '^--\?[a-zA-Z0-9-]\+='; then
          err "configure expects arguments of the form '-prefix /foo/bar'," \
              "not '-prefix=/foo/bar' (note the '=')."
@@ -211,6 +237,7 @@ touch s.h m.h Makefile
 # Write options to Makefile
 
 echo "# generated by ./configure $configure_options" >> Makefile
+echo "CONFIGURE_ARGS=$configure_options" >> Makefile
 
 # Where to install
 
@@ -671,7 +698,7 @@ if test $with_sharedlibs = "yes"; then
       mkmaindll="$flexlink -maindll"
       shared_libraries_supported=true;;
     *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*\
-    |*-*-openbsd*|*-*-netbsd*|*-*-gnu*|*-*-haiku*)
+    |*-*-openbsd*|*-*-netbsd*|*-*-dragonfly*|*-*-gnu*|*-*-haiku*)
       sharedcccompopts="-fPIC"
       mksharedlib="$bytecc -shared"
       bytecclinkopts="$bytecclinkopts -Wl,-E"
@@ -779,6 +806,7 @@ if test $with_sharedlibs = "yes"; then
     sparc*-*-linux*)              natdynlink=true;;
     i686-*-kfreebsd*)             natdynlink=true;;
     x86_64-*-kfreebsd*)           natdynlink=true;;
+    x86_64-*-dragonfly*)          natdynlink=true;;
     i[3456]86-*-freebsd*)         natdynlink=true;;
     x86_64-*-freebsd*)            natdynlink=true;;
     i[3456]86-*-openbsd*)         natdynlink=true;;
@@ -852,6 +880,7 @@ case "$target" in
   zaurus*-*-openbsd*)           arch=arm; system=bsd;;
   x86_64-*-linux*)              arch=amd64; system=linux;;
   x86_64-*-gnu*)                arch=amd64; system=gnu;;
+  x86_64-*-dragonfly*)          arch=amd64; system=dragonfly;;
   x86_64-*-freebsd*)            arch=amd64; system=freebsd;;
   x86_64-*-netbsd*)             arch=amd64; system=netbsd;;
   x86_64-*-openbsd*)            arch=amd64; system=openbsd;;
@@ -913,7 +942,7 @@ case "$arch,$system" in
   amd64,solaris)  as="${TOOLPREF}as --64"
                   aspp="${TOOLPREF}gcc -m64 -c";;
   i386,solaris)   as="${TOOLPREF}as"
-                  aspp="/usr/ccs/bin/${TOOLPREF}as -P";;
+                  aspp="${TOOLPREF}gcc -c";;
   power,elf)      if $arch64; then
                     as="${TOOLPREF}as -a64 -mppc64"
                     aspp="${TOOLPREF}gcc -m64 -c"
@@ -930,6 +959,8 @@ case "$arch,$system" in
                   esac;;
   arm,freebsd)    as="${TOOLPREF}cc -c"
                   aspp="${TOOLPREF}cc -c";;
+  *,dragonfly)    as="${TOOLPREF}as"
+                  aspp="${TOOLPREF}cc -c";;
   *,freebsd)      as="${TOOLPREF}as"
                   aspp="${TOOLPREF}cc -c";;
   amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*)
@@ -985,27 +1016,27 @@ echo "#define OCAML_STDLIB_DIR \"$libdir\"" >> s.h
 
 # Do #! scripts work?
 
-if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then
+if (SHELL=/bin/sh; export SHELL; (./hashbang || ./hashbang2) >/dev/null); then
   inf "#! appears to work in shell scripts."
   case "$target" in
     *-*-sunos*|*-*-unicos*)
       wrn "We won't use it, though, because under SunOS and Unicos it breaks " \
           "on pathnames longer than 30 characters"
-      echo "SHARPBANGSCRIPTS=false" >> Makefile;;
+      echo "HASHBANGSCRIPTS=false" >> Makefile;;
     *-*-cygwin*)
       wrn "We won't use it, though, because of conflicts with .exe extension " \
           "under Cygwin"
-      echo "SHARPBANGSCRIPTS=false" >> Makefile;;
+      echo "HASHBANGSCRIPTS=false" >> Makefile;;
     *-*-mingw*)
       inf "We won't use it, though, because it's on the target platform " \
           "it would be used and windows doesn't support it."
-      echo "SHARPBANGSCRIPTS=false" >> Makefile;;
+      echo "HASHBANGSCRIPTS=false" >> Makefile;;
     *)
-      echo "SHARPBANGSCRIPTS=true" >> Makefile;;
+      echo "HASHBANGSCRIPTS=true" >> Makefile;;
   esac
 else
   inf "No support for #! in shell scripts"
-  echo "SHARPBANGSCRIPTS=false" >> Makefile
+  echo "HASHBANGSCRIPTS=false" >> Makefile
 fi
 
 # Use 64-bit file offset if possible
@@ -1094,6 +1125,17 @@ echo "GRAPHLIB=$graphlib" >> Makefile
 
 otherlibraries="$unixlib str num dynlink bigarray"
 
+# Spacetime profiling is only available for native code on 64-bit targets.
+
+case "$native_compiler" in
+    true)
+      if $arch64; then
+        otherlibraries="$otherlibraries raw_spacetime_lib"
+      fi
+      ;;
+    *) ;;
+esac
+
 # For the Unix library
 
 has_sockets=no
@@ -1230,6 +1272,11 @@ if sh ./hasgot select && \
   has_select=yes
 fi
 
+if sh ./hasgot nanosleep ; then
+  inf "nanosleep() found."
+  echo "#define HAS_NANOSLEEP" >> s.h
+fi
+
 if sh ./hasgot symlink readlink lstat;  then
   inf "symlink() found."
   echo "#define HAS_SYMLINK" >> s.h
@@ -1445,6 +1492,8 @@ if test "$pthread_wanted" = "yes"; then
   case "$target" in
     *-*-solaris*)  pthread_link="-lpthread -lposix4"
                    pthread_caml_link="-cclib -lpthread -cclib -lposix4";;
+    *-*-dragon*)   pthread_link="-pthread"
+                   pthread_caml_link="-cclib -pthread";;
     *-*-freebsd*)  pthread_link="-pthread"
                    pthread_caml_link="-cclib -pthread";;
     *-*-openbsd*)  pthread_link="-pthread"
@@ -1461,7 +1510,7 @@ if test "$pthread_wanted" = "yes"; then
     bytecccompopts="$bytecccompopts -D_REENTRANT"
     nativecccompopts="$nativecccompopts -D_REENTRANT"
     case "$target" in
-      *-*-freebsd*)
+      *-*-freebsd*|*-*-dragonfly*)
           bytecccompopts="$bytecccompopts -D_THREAD_SAFE"
           nativecccompopts="$nativecccompopts -D_THREAD_SAFE";;
       *-*-openbsd*)
@@ -1631,6 +1680,7 @@ if test "$x11_include" = "not found"; then
       else
         x11_libs="-L$dir"
         case "$target" in
+          *-*-freebsd*|*-*-dragonfly*) x11_link="-L$dir -lX11";;
           *-kfreebsd*-gnu) x11_link="-L$dir -lX11";;
           *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";;
           *) x11_link="-L$dir -lX11";;
@@ -1737,6 +1787,120 @@ else
     has_huge_pages=false
 fi
 
+# Spacetime profiling, including libunwind detection
+
+# The number of bits used for profiling information is configurable here.
+# The more bits used for profiling, the smaller will be Max_wosize.
+# Note that PROFINFO_WIDTH must still be defined even if not configuring
+# for Spacetime (see comment in byterun/caml/mlvalues.h on [Profinfo_hd]).
+profinfo_width=26
+echo "#define PROFINFO_WIDTH $profinfo_width" >> m.h
+if $with_spacetime; then
+  case "$arch,$system" in
+    amd64,*)
+      spacetime_supported=true
+      ;;
+    *)
+      spacetime_supported=false
+      ;;
+  esac
+  libunwind_warning=false
+  if $spacetime_supported; then
+    echo "Spacetime profiling will be available."
+    echo "#define WITH_SPACETIME" >> m.h
+    if $disable_libunwind; then
+      has_libunwind=no
+      libunwind_available=false
+      echo "libunwind support for Spacetime profiling was explicitly disabled."
+    else
+      # On Mac OS X, we always use the system libunwind.
+      if test "$libunwind_lib_dir" != ""; then
+        case "$arch,$system" in
+          amd64,macosx)
+            inf "[WARNING] -libunwind* options are ignored on Mac OS X"
+            libunwind_warning=true
+            libunwind_lib="-framework System"
+            libunwind_lib_temp="$libunwind_lib"
+            # We need unwinding information at runtime, but since we use
+            # -no_compact_unwind, we also need -keep_dwarf_unwind otherwise
+            # the OS X linker will chuck away the DWARF-like (.eh_frame)
+            # information.  (Older versions of OS X don't provide this.)
+            mkexe="$mkexe -Wl,-keep_dwarf_unwind"
+            mksharedlib="$mksharedlib -Wl,-keep_dwarf_unwind"
+            ;;
+          *)
+            libunwind_lib="-L$libunwind_lib_dir -lunwind -lunwind-x86_64"
+            libunwind_lib_temp="-Xl $libunwind_lib"
+            ;;
+        esac
+      else
+        case "$arch,$system" in
+          amd64,macosx)
+            libunwind_lib="-framework System"
+            libunwind_lib_temp="$libunwind_lib"
+            mkexe="$mkexe -Wl,-keep_dwarf_unwind"
+            mksharedlib="$mksharedlib -Wl,-keep_dwarf_unwind"
+            ;;
+          *)
+            libunwind_lib="-lunwind -lunwind-x86_64"
+            libunwind_lib_temp="$libunwind_lib"
+            ;;
+        esac
+      fi
+      if test "$libunwind_include_dir" != ""; then
+        case "$arch,$system" in
+          amd64,macosx)
+            if ! $libunwind_warning; then
+              inf "[WARNING] -libunwind* options are ignored on Mac OS X"
+            fi
+            libunwind_include=""
+            ;;
+          *)
+            libunwind_include="-I$libunwind_include_dir"
+            ;;
+        esac
+      else
+        libunwind_include=""
+      fi
+      if sh ./hasgot -i libunwind.h $libunwind_lib_temp $libunwind_include; \
+      then
+        echo "#define HAS_LIBUNWIND" >> s.h
+        has_libunwind=yes
+        libunwind_available=true
+        echo "libunwind support for Spacetime profiling will be available."
+      else
+        has_libunwind=no
+        libunwind_available=false
+        echo "libunwind support for Spacetime profiling will not be available."
+      fi
+    fi
+  else
+    echo "Spacetime profiling is not available on 32-bit platforms."
+    with_spacetime=false
+    libunwind_available=false
+    has_libunwind=no
+  fi
+fi
+
+if ! $shared_libraries_supported; then
+  with_cplugins=false
+fi
+
+if $with_fpic; then
+  bytecccompopts="$bytecccompopts $sharedcccompopts"
+  nativecccompopts="$nativecccompopts $sharedcccompopts"
+  aspp="$aspp $sharedcccompopts"
+fi
+
+
+if $with_cplugins; then
+  echo "#define CAML_WITH_CPLUGINS" >> m.h
+fi
+
+if $with_fpic; then
+  echo "#define CAML_WITH_FPIC" >> m.h
+fi
+
 # Finish generated files
 
 cclibs="$cclibs $mathlib"
@@ -1811,12 +1975,20 @@ echo "WITH_DEBUGGER=${with_debugger}" >>Makefile
 echo "WITH_OCAMLDOC=${with_ocamldoc}" >>Makefile
 echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile
 echo "WITH_FRAME_POINTERS=$with_frame_pointers" >> Makefile
+echo "WITH_SPACETIME=$with_spacetime" >> Makefile
+echo "LIBUNWIND_AVAILABLE=$libunwind_available" >> Makefile
+echo "LIBUNWIND_INCLUDE_FLAGS=$libunwind_include" >> Makefile
+echo "LIBUNWIND_LINK_FLAGS=$libunwind_lib" >> Makefile
+echo "PROFINFO_WIDTH=$profinfo_width" >> Makefile
+echo "WITH_CPLUGINS=$with_cplugins" >> Makefile
+echo "WITH_FPIC=$with_fpic" >> Makefile
 echo "TARGET=$target" >> Makefile
 echo "HOST=$host" >> Makefile
 if [ "$ostype" = Cygwin ]; then
   echo "DIFF=diff -q --strip-trailing-cr" >>Makefile
 fi
 echo "FLAMBDA=$flambda" >> Makefile
+echo "SAFE_STRING=$safe_string" >> Makefile
 echo "MAX_TESTSUITE_DIR_RETRIES=$max_testsuite_dir_retries" >> Makefile
 
 
@@ -1880,6 +2052,38 @@ else
   else
   inf "        naked pointers forbidden.. no"
   fi
+  if $with_spacetime; then
+    inf "        spacetime profiling....... yes"
+    inf "          ... with libunwind...... $has_libunwind"
+  else
+    inf "        spacetime profiling....... no"
+  fi
+  case "$arch,$system" in
+    amd64,macosx)
+      ;;
+    amd64,*)
+      if test "$has_libunwind" = "yes"; then
+        if test "$libunwind_include_dir" != ""; then
+          inf "        libunwind include dir..... $libunwind_include_dir"
+        fi
+        if test "$libunwind_lib_dir" != ""; then
+          inf "        libunwind library dir..... $libunwind_lib_dir"
+        fi
+      fi
+      ;;
+    *)
+      ;;
+  esac
+  if $with_cplugins; then
+  inf "        C plugins................. yes"
+  else
+  inf "        C plugins................. no"
+  fi
+  if $with_fpic; then
+  inf "        compile with -fPIC........ yes"
+  else
+  inf "        compile with -fPIC........ no"
+  fi
   inf "        native dynlink ........... $natdynlink"
   if test "$profiling" = "prof"; then
   inf "        profiling with gprof ..... supported"
@@ -1891,6 +2095,11 @@ else
   else
   inf "        using flambda middle-end . no"
   fi
+  if test "$safe_string" = "true"; then
+  inf "        safe strings ............. yes"
+  else
+  inf "        safe strings ............. no"
+  fi
 fi
 
 if test "$with_debugger" = "ocamldebugger"; then

diff --git a/debugger/.depend b/debugger/.depend
index b62541619abd88226791835e340cb41db5a98680..ed8ab4bf5a17b73a2bdb2944a7cc596354b345bd 100644 (file)
--- a/debugger/.depend
+++ b/debugger/.depend
@@ -1,46 +1,11 @@
-breakpoints.cmi : primitives.cmi ../bytecomp/instruct.cmi
-checkpoints.cmi : primitives.cmi debugcom.cmi
-command_line.cmi :
-debugcom.cmi : primitives.cmi
-debugger_config.cmi :
-dynlink.cmi :
-eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
-    ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \
-    ../typing/env.cmi debugcom.cmi
-events.cmi : ../bytecomp/instruct.cmi
-exec.cmi :
-frames.cmi : primitives.cmi ../bytecomp/instruct.cmi
-history.cmi :
-input_handling.cmi : primitives.cmi
-int64ops.cmi :
-lexer.cmi : parser.cmi
-loadprinter.cmi : ../parsing/longident.cmi dynlink.cmi
-parameters.cmi :
-parser.cmi : parser_aux.cmi ../parsing/longident.cmi
-parser_aux.cmi : primitives.cmi ../parsing/longident.cmi
-pattern_matching.cmi : ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi
-pos.cmi : ../bytecomp/instruct.cmi
-primitives.cmi : $(UNIXDIR)/unix.cmi
-printval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
-    ../typing/env.cmi debugcom.cmi
-program_loading.cmi : primitives.cmi
-program_management.cmi :
-question.cmi :
-show_information.cmi : ../bytecomp/instruct.cmi
-show_source.cmi : ../bytecomp/instruct.cmi
-source.cmi :
-symbols.cmi : ../bytecomp/instruct.cmi
-time_travel.cmi : primitives.cmi
-trap_barrier.cmi :
-unix_tools.cmi : $(UNIXDIR)/unix.cmi
-breakpoints.cmo : symbols.cmi primitives.cmi pos.cmi \
-    ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \
-    breakpoints.cmi
-breakpoints.cmx : symbols.cmx primitives.cmx pos.cmx \
-    ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \
-    breakpoints.cmi
+breakpoints.cmo : symbols.cmi pos.cmi ../bytecomp/instruct.cmi exec.cmi \
+    debugcom.cmi checkpoints.cmi breakpoints.cmi
+breakpoints.cmx : symbols.cmx pos.cmx ../bytecomp/instruct.cmx exec.cmx \
+    debugcom.cmx checkpoints.cmx breakpoints.cmi
+breakpoints.cmi : ../bytecomp/instruct.cmi
 checkpoints.cmo : primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi
 checkpoints.cmx : primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi
+checkpoints.cmi : primitives.cmi debugcom.cmi
 command_line.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \
     ../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \
     show_source.cmi show_information.cmi question.cmi program_management.cmi \
@@ -61,20 +26,15 @@ command_line.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \
     events.cmx eval.cmx ../typing/envaux.cmx ../typing/env.cmx \
     debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../utils/config.cmx \
     checkpoints.cmx breakpoints.cmx command_line.cmi
+command_line.cmi :
 debugcom.cmo : primitives.cmi ../utils/misc.cmi int64ops.cmi \
     input_handling.cmi debugcom.cmi
 debugcom.cmx : primitives.cmx ../utils/misc.cmx int64ops.cmx \
     input_handling.cmx debugcom.cmi
+debugcom.cmi : primitives.cmi
 debugger_config.cmo : int64ops.cmi debugger_config.cmi
 debugger_config.cmx : int64ops.cmx debugger_config.cmi
-dynlink.cmo : ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \
-    ../utils/misc.cmi ../bytecomp/meta.cmi ../bytecomp/dll.cmi \
-    ../utils/consistbl.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \
-    ../typing/cmi_format.cmi dynlink.cmi
-dynlink.cmx : ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \
-    ../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \
-    ../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \
-    ../typing/cmi_format.cmx dynlink.cmi
+debugger_config.cmi :
 eval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \
     printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \
     ../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \
@@ -87,34 +47,47 @@ eval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \
     ../parsing/longident.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \
     frames.cmx ../typing/env.cmx debugcom.cmx ../typing/ctype.cmx \
     ../typing/btype.cmx eval.cmi
+eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
+    ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \
+    ../typing/env.cmi debugcom.cmi
 events.cmo : ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi
 events.cmx : ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi
+events.cmi : ../bytecomp/instruct.cmi
 exec.cmo : exec.cmi
 exec.cmx : exec.cmi
+exec.cmi :
 frames.cmo : symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi \
     events.cmi debugcom.cmi frames.cmi
 frames.cmx : symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx \
     events.cmx debugcom.cmx frames.cmi
+frames.cmi : ../bytecomp/instruct.cmi
 history.cmo : primitives.cmi int64ops.cmi debugger_config.cmi \
     checkpoints.cmi history.cmi
 history.cmx : primitives.cmx int64ops.cmx debugger_config.cmx \
     checkpoints.cmx history.cmi
+history.cmi :
 input_handling.cmo : $(UNIXDIR)/unix.cmi primitives.cmi \
     input_handling.cmi
 input_handling.cmx : $(UNIXDIR)/unix.cmx primitives.cmx \
     input_handling.cmi
+input_handling.cmi : primitives.cmi
 int64ops.cmo : int64ops.cmi
 int64ops.cmx : int64ops.cmi
+int64ops.cmi :
 lexer.cmo : parser.cmi lexer.cmi
 lexer.cmx : parser.cmx lexer.cmi
+lexer.cmi : parser.cmi
 loadprinter.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \
     ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \
     ../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \
-    dynlink.cmi ../typing/ctype.cmi ../utils/config.cmi loadprinter.cmi
+    ../typing/ctype.cmi ../utils/config.cmi ../driver/compdynlink.cmi \
+    loadprinter.cmi
 loadprinter.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \
     ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \
     ../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \
-    dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi
+    ../typing/ctype.cmx ../utils/config.cmx ../driver/compdynlink.cmi \
+    loadprinter.cmi
+loadprinter.cmi : ../parsing/longident.cmi ../driver/compdynlink.cmi
 main.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \
     show_information.cmi question.cmi program_management.cmi primitives.cmi \
     parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \
@@ -131,22 +104,26 @@ parameters.cmo : primitives.cmi ../typing/envaux.cmi debugger_config.cmi \
     ../utils/config.cmi parameters.cmi
 parameters.cmx : primitives.cmx ../typing/envaux.cmx debugger_config.cmx \
     ../utils/config.cmx parameters.cmi
+parameters.cmi :
 parser.cmo : parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \
     input_handling.cmi parser.cmi
 parser.cmx : parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \
     input_handling.cmx parser.cmi
+parser.cmi : parser_aux.cmi ../parsing/longident.cmi
+parser_aux.cmi : ../parsing/longident.cmi
 pattern_matching.cmo : ../typing/typedtree.cmi parser_aux.cmi \
     ../utils/misc.cmi debugger_config.cmi debugcom.cmi ../typing/ctype.cmi \
     pattern_matching.cmi
 pattern_matching.cmx : ../typing/typedtree.cmx parser_aux.cmi \
     ../utils/misc.cmx debugger_config.cmx debugcom.cmx ../typing/ctype.cmx \
     pattern_matching.cmi
-pos.cmo : source.cmi primitives.cmi ../parsing/location.cmi \
-    ../bytecomp/instruct.cmi pos.cmi
-pos.cmx : source.cmx primitives.cmx ../parsing/location.cmx \
-    ../bytecomp/instruct.cmx pos.cmi
+pattern_matching.cmi : ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi
+pos.cmo : ../parsing/location.cmi ../bytecomp/instruct.cmi pos.cmi
+pos.cmx : ../parsing/location.cmx ../bytecomp/instruct.cmx pos.cmi
+pos.cmi : ../bytecomp/instruct.cmi
 primitives.cmo : $(UNIXDIR)/unix.cmi primitives.cmi
 primitives.cmx : $(UNIXDIR)/unix.cmx primitives.cmi
+primitives.cmi : $(UNIXDIR)/unix.cmi
 printval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi \
     ../typing/printtyp.cmi ../typing/path.cmi parser_aux.cmi \
     ../typing/outcometree.cmi ../typing/oprint.cmi \
@@ -155,12 +132,15 @@ printval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx \
     ../typing/printtyp.cmx ../typing/path.cmx parser_aux.cmi \
     ../typing/outcometree.cmi ../typing/oprint.cmx \
     ../toplevel/genprintval.cmx debugcom.cmx printval.cmi
+printval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
+    ../typing/env.cmi debugcom.cmi
 program_loading.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \
     primitives.cmi parameters.cmi input_handling.cmi debugger_config.cmi \
     program_loading.cmi
 program_loading.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \
     primitives.cmx parameters.cmx input_handling.cmx debugger_config.cmx \
     program_loading.cmi
+program_loading.cmi : primitives.cmi
 program_management.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \
     time_travel.cmi symbols.cmi question.cmi program_loading.cmi \
     primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \
@@ -171,8 +151,10 @@ program_management.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \
     primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \
     ../typing/envaux.cmx debugger_config.cmx ../utils/config.cmx \
     breakpoints.cmx program_management.cmi
+program_management.cmi :
 question.cmo : primitives.cmi lexer.cmi input_handling.cmi question.cmi
 question.cmx : primitives.cmx lexer.cmx input_handling.cmx question.cmi
+question.cmi :
 show_information.cmo : symbols.cmi source.cmi show_source.cmi printval.cmi \
     parameters.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi \
     events.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \
@@ -181,22 +163,26 @@ show_information.cmx : symbols.cmx source.cmx show_source.cmx printval.cmx \
     parameters.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx \
     events.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \
     show_information.cmi
+show_information.cmi : ../bytecomp/instruct.cmi
 show_source.cmo : source.cmi primitives.cmi parameters.cmi \
     ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \
     debugger_config.cmi show_source.cmi
 show_source.cmx : source.cmx primitives.cmx parameters.cmx \
     ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \
     debugger_config.cmx show_source.cmi
+show_source.cmi : ../bytecomp/instruct.cmi
 source.cmo : primitives.cmi ../utils/misc.cmi debugger_config.cmi \
     ../utils/config.cmi source.cmi
 source.cmx : primitives.cmx ../utils/misc.cmx debugger_config.cmx \
     ../utils/config.cmx source.cmi
+source.cmi :
 symbols.cmo : ../bytecomp/symtable.cmi program_loading.cmi \
     ../bytecomp/instruct.cmi events.cmi debugger_config.cmi debugcom.cmi \
     checkpoints.cmi ../bytecomp/bytesections.cmi symbols.cmi
 symbols.cmx : ../bytecomp/symtable.cmx program_loading.cmx \
     ../bytecomp/instruct.cmx events.cmx debugger_config.cmx debugcom.cmx \
     checkpoints.cmx ../bytecomp/bytesections.cmx symbols.cmi
+symbols.cmi : ../bytecomp/instruct.cmi
 time_travel.cmo : trap_barrier.cmi symbols.cmi question.cmi \
     program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \
     ../bytecomp/instruct.cmi input_handling.cmi exec.cmi events.cmi \
@@ -207,9 +193,10 @@ time_travel.cmx : trap_barrier.cmx symbols.cmx question.cmx \
     ../bytecomp/instruct.cmx input_handling.cmx exec.cmx events.cmx \
     debugger_config.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \
     time_travel.cmi
+time_travel.cmi : primitives.cmi
 trap_barrier.cmo : exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi
 trap_barrier.cmx : exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi
-unix_tools.cmo : $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \
-    unix_tools.cmi
-unix_tools.cmx : $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \
-    unix_tools.cmi
+trap_barrier.cmi :
+unix_tools.cmo : $(UNIXDIR)/unix.cmi ../utils/misc.cmi unix_tools.cmi
+unix_tools.cmx : $(UNIXDIR)/unix.cmx ../utils/misc.cmx unix_tools.cmi
+unix_tools.cmi : $(UNIXDIR)/unix.cmi

diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared
index 520f883d28965a52f74d227394e55dbb136e1982..aed8aa12b53b8676cdcb62f3dbddcb57592f2b01 100644 (file)
--- a/debugger/Makefile.shared
+++ b/debugger/Makefile.shared
@@ -18,7 +18,8 @@ CAMLRUN ?= ../boot/ocamlrun
 CAMLYACC ?= ../boot/ocamlyacc
 
 CAMLC=$(CAMLRUN) ../ocamlc -nostdlib -I ../stdlib
-COMPFLAGS=-warn-error A -safe-string $(INCLUDES)
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \
+          -safe-string -strict-sequence -strict-formats
 LINKFLAGS=-linkall -I $(UNIXDIR)
 YACCFLAGS=
 CAMLLEX=$(CAMLRUN) ../boot/ocamllex
@@ -29,7 +30,7 @@ INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
 
 INCLUDES=\
   -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \
-  -I $(UNIXDIR)
+  -I ../driver -I $(UNIXDIR)
 
 OTHEROBJS=\
   $(UNIXDIR)/unix.cma \
@@ -51,12 +52,11 @@ OTHEROBJS=\
   ../typing/envaux.cmo \
   ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \
   ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \
-  ../bytecomp/opcodes.cmo \
+  ../bytecomp/opcodes.cmo ../driver/compdynlink.cmo \
   ../toplevel/genprintval.cmo
 
 
 OBJS=\
-       dynlink.cmo \
        int64ops.cmo \
        primitives.cmo \
        unix_tools.cmo \
@@ -110,7 +110,7 @@ clean::
        $(CAMLC) -c $(COMPFLAGS) $<
 
 depend: beforedepend
-       $(CAMLDEP) $(DEPFLAGS) *.mli *.ml \
+       $(CAMLDEP) -slash $(DEPFLAGS) *.mli *.ml \
        | sed -e 's,$(UNIXDIR)/,$$(UNIXDIR)/,' > .depend
 
 lexer.ml: lexer.mll
@@ -125,13 +125,4 @@ clean::
        rm -f parser.ml parser.mli
 beforedepend:: parser.ml parser.mli
 
-dynlink.ml: ../otherlibs/dynlink/dynlink.ml
-       grep -v 'REMOVE_ME for ../../debugger/dynlink.ml' \
-            ../otherlibs/dynlink/dynlink.ml >dynlink.ml
-dynlink.mli: ../otherlibs/dynlink/dynlink.mli
-       cp ../otherlibs/dynlink/dynlink.mli .
-clean::
-       rm -f dynlink.ml dynlink.mli
-beforedepend:: dynlink.ml dynlink.mli
-
 include .depend

diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml
index 587b916435f15bb81f1c0d20343e1f488eea4ec4..edba0428449ca471893eed42ae1d4c8c480be310 100644 (file)
--- a/debugger/breakpoints.ml
+++ b/debugger/breakpoints.ml
@@ -19,7 +19,6 @@
 open Checkpoints
 open Debugcom
 open Instruct
-open Primitives
 open Printf
 
 (*** Debugging. ***)
@@ -137,7 +136,7 @@ let execute_without_breakpoints f =
       f ();
       change_version version pos
     with
-      x ->
+      _ ->
         change_version version pos
 
 (* Add a position in the position list. *)

diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli
index 2d5a8d87c69bea04806092cf6c57657c834f69ba..d0e76c3675b6700358593ea508c28d9e6f17edcf 100644 (file)
--- a/debugger/breakpoints.mli
+++ b/debugger/breakpoints.mli
@@ -16,7 +16,6 @@
 
 (******************************* Breakpoints ***************************)
 
-open Primitives
 open Instruct
 
 (*** Debugging. ***)

diff --git a/debugger/command_line.ml b/debugger/command_line.ml
index 4cb6a4fc35ef3ea40929cd0c3ed7a5df030a121f..b8b091345b6a374e58859245f1cf3480959df0c8 100644 (file)
--- a/debugger/command_line.ml
+++ b/debugger/command_line.ml
@@ -179,7 +179,7 @@ let interprete_line ppf line =
               i.instr_action ppf lexbuf;
               resume_user_input ();
               i.instr_repeat
-          | l ->
+          | _ ->
               error "Ambiguous command."
           end
       | None ->
@@ -216,7 +216,7 @@ let line_loop ppf line_buffer =
         error ("System error: " ^ s) *)
 
 (** Instructions. **)
-let instr_cd ppf lexbuf =
+let instr_cd _ppf lexbuf =
   let dir = argument_eol argument lexbuf in
     if ask_kill_program () then
       try
@@ -225,7 +225,7 @@ let instr_cd ppf lexbuf =
       | Sys_error s ->
           error s
 
-let instr_shell ppf lexbuf =
+let instr_shell _ppf lexbuf =
   let cmdarg = argument_list_eol argument lexbuf in
   let cmd = String.concat " " cmdarg in
   (* perhaps we should use $SHELL -c ? *)
@@ -233,7 +233,7 @@ let instr_shell ppf lexbuf =
   if (err != 0) then
     eprintf "Shell command %S failed with exit code %d\n%!" cmd err
 
-let instr_env ppf lexbuf =
+let instr_env _ppf lexbuf =
   let cmdarg = argument_list_eol argument lexbuf in
   let cmdarg = string_trim (String.concat " " cmdarg) in
   if cmdarg <> "" then
@@ -286,7 +286,7 @@ let instr_dir ppf lexbuf =
                  dirs)
       Debugger_config.load_path_for
 
-let instr_kill ppf lexbuf =
+let instr_kill _ppf lexbuf =
   eol lexbuf;
   if not !loaded then error "The program is not being run.";
   if (yes_or_no "Kill the program being debugged") then begin
@@ -393,7 +393,7 @@ let print_info_list ppf =
   let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name)  in
   fprintf ppf "List of info commands: %a@." pr_infos !info_list
 
-let instr_complete ppf lexbuf =
+let instr_complete _ppf lexbuf =
   let ppf = Format.err_formatter in
   let rec print_list l =
     try
@@ -465,7 +465,7 @@ let instr_help ppf lexbuf =
           find_variable
             (fun v _ _ ->
                print_help ("show " ^ v.var_name) ("show " ^ v.var_help))
-            (fun v ->
+            (fun _v ->
                print_help "show" "display debugger variable.";
                print_variable_list ppf)
             ppf
@@ -585,8 +585,8 @@ let instr_source ppf lexbuf =
 
 let instr_set =
   find_variable
-    (fun {var_action = (funct, _)} ppf lexbuf -> funct lexbuf)
-    (function ppf -> error "Argument required.")
+    (fun {var_action = (funct, _)} _ppf lexbuf -> funct lexbuf)
+    (function _ppf -> error "Argument required.")
 
 let instr_show =
   find_variable
@@ -600,8 +600,8 @@ let instr_show =
 
 let instr_info =
   find_info
-    (fun i ppf lexbuf -> i.info_action lexbuf)
-    (function ppf ->
+    (fun i _ppf lexbuf -> i.info_action lexbuf)
+    (function _ppf ->
        error "\"info\" must be followed by the name of an info command.")
 
 let instr_break ppf lexbuf =
@@ -673,7 +673,7 @@ let instr_break ppf lexbuf =
         | Not_found ->
             eprintf "Can\'t find any event there.@."
 
-let instr_delete ppf lexbuf =
+let instr_delete _ppf lexbuf =
   match integer_list_eol Lexer.lexeme lexbuf with
   | [] ->
       if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints"
@@ -771,7 +771,7 @@ let instr_last ppf lexbuf =
     go_to (History.previous_time count);
     show_current_event ppf
 
-let instr_list ppf lexbuf =
+let instr_list _ppf lexbuf =
   let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in
     let (curr_mod, line, column) =
       try
@@ -866,9 +866,9 @@ let loading_mode_variable ppf =
   (find_ident
      "loading mode"
      (matching_elements (ref loading_modes) fst)
-     (fun (_, mode) ppf lexbuf ->
+     (fun (_, mode) _ppf lexbuf ->
         eol lexbuf; set_launching_function mode)
-     (function ppf -> error "Syntax error.")
+     (function _ppf -> error "Syntax error.")
      ppf),
   function ppf ->
     let rec find = function
@@ -946,7 +946,7 @@ let info_breakpoints ppf lexbuf =
   end
 ;;
 
-let info_events ppf lexbuf =
+let info_events _ppf lexbuf =
   ensure_loaded ();
   let mdle =
     convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf))
@@ -1210,7 +1210,7 @@ It can be either:\n\
        var_action = follow_fork_variable;
        var_help =
 "process to follow after forking.\n\
-It can be either :
+It can be either :\n\
   child: the newly created process.\n\
   parent: the process that called fork.\n" }];
 

diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml
index a8079cbcd09f729e67854368f320a434efec288f..b70eedd1e688fa97d57f32c417bf66ec68ded8cc 100644 (file)
--- a/debugger/debugcom.ml
+++ b/debugger/debugcom.ml
@@ -282,7 +282,7 @@ module Remote_value =
       Remote(input_remote_value !conn.io_in)
 
     let closure_code = function
-    | Local obj -> assert false
+    | Local _ -> assert false
     | Remote v ->
         output_char !conn.io_out 'C';
         output_remote_value !conn.io_out v;

diff --git a/debugger/eval.ml b/debugger/eval.ml
index e4e9aaf15051c56a530cc9b84bb4ce5db1ba95b5..e6baa80b477a83fb2167fe9a80129ac99e8ff07a 100644 (file)
--- a/debugger/eval.ml
+++ b/debugger/eval.ml
@@ -61,12 +61,12 @@ let rec path event = function
         | None ->
             raise(Error(Unbound_identifier id))
         end
-  | Pdot(root, fieldname, pos) ->
+  | Pdot(root, _fieldname, pos) ->
       let v = path event root in
       if not (Debugcom.Remote_value.is_block v) then
         raise(Error(Not_initialized_yet root));
       Debugcom.Remote_value.field v pos
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Eval.path: Papply"
 
 let rec expression event env = function
@@ -135,10 +135,10 @@ let rec expression event env = function
   | E_field(arg, lbl) ->
       let (v, ty) = expression event env arg in
       begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with
-        Tconstr(path, args, _) ->
+        Tconstr(path, _, _) ->
           let tydesc = Env.find_type path env in
           begin match tydesc.type_kind with
-            Type_record(lbl_list, repr) ->
+            Type_record(lbl_list, _repr) ->
               let (pos, ty_res) =
                 find_label lbl env ty path tydesc 0 lbl_list in
               (Debugcom.Remote_value.field v pos, ty_res)

diff --git a/debugger/exec.ml b/debugger/exec.ml
index 0fc595288b98de0fe41e60a9ba2c40e1cc752f9c..df940165e5d90a729b02332b1871cff71ba6fea7 100644 (file)
--- a/debugger/exec.ml
+++ b/debugger/exec.ml
@@ -20,7 +20,7 @@ let interrupted = ref false
 
 let is_protected = ref false
 
-let break signum =
+let break _signum =
   if !is_protected
   then interrupted := true
   else raise Sys.Break

diff --git a/debugger/frames.ml b/debugger/frames.ml
index 2db2e1b1a0f782f4763097fb45f6f974e4bd8da5..96b7ce15315df550b5ddffd61a431636310e06aa 100644 (file)
--- a/debugger/frames.ml
+++ b/debugger/frames.ml
@@ -125,6 +125,6 @@ let do_backtrace action =
 
 let stack_depth () =
   let num_frames = ref 0 in
-  do_backtrace (function Some ev -> incr num_frames; true
+  do_backtrace (function Some _ev -> incr num_frames; true
                        | None -> num_frames := -1; false);
   !num_frames

diff --git a/debugger/frames.mli b/debugger/frames.mli
index faaf516b128c710df64c12de4385b4edd050c50c..514aa2e361b6a4f4da38197c27946b61879625ea 100644 (file)
--- a/debugger/frames.mli
+++ b/debugger/frames.mli
@@ -17,7 +17,6 @@
 (****************************** Frames *********************************)
 
 open Instruct
-open Primitives
 
 (* Current frame number *)
 val current_frame : int ref

diff --git a/debugger/lexer.mll b/debugger/lexer.mll
index 133d27325bda0ed0b1aa54039c0cdc852cafd65e..8570b152a86582c473688a3084bf425609055e25 100644 (file)
--- a/debugger/lexer.mll
+++ b/debugger/lexer.mll
@@ -78,7 +78,7 @@ and lexeme =    (* Read a lexeme *)
   | "."
       { DOT }
   | "#"
-      { SHARP }
+      { HASH }
   | "@"
       { AT }
   | "$"

diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml
index 113ae89f7eda8f41a5d637a35e8d0e6282744b4d..a1c2fcfed62d658473a98ca9099dac936f8bde67 100644 (file)
--- a/debugger/loadprinter.ml
+++ b/debugger/loadprinter.ml
@@ -23,7 +23,7 @@ open Types
 (* Error report *)
 
 type error =
-  | Load_failure of Dynlink.error
+  | Load_failure of Compdynlink.error
   | Unbound_identifier of Longident.t
   | Unavailable_module of string * Longident.t
   | Wrong_type of Longident.t
@@ -41,8 +41,8 @@ let use_debugger_symtable fn arg =
   let old_symtable = Symtable.current_state() in
   begin match !debugger_symtable with
   | None ->
-      Dynlink.init();
-      Dynlink.allow_unsafe_modules true;
+      Compdynlink.init();
+      Compdynlink.allow_unsafe_modules true;
       debugger_symtable := Some(Symtable.current_state())
   | Some st ->
       Symtable.restore_state st
@@ -63,7 +63,7 @@ open Format
 let rec loadfiles ppf name =
   try
     let filename = find_in_path !Config.load_path name in
-    use_debugger_symtable Dynlink.loadfile filename;
+    use_debugger_symtable Compdynlink.loadfile filename;
     let d = Filename.dirname name in
     if d <> Filename.current_dir_name then begin
       if not (List.mem d !Config.load_path) then
@@ -72,7 +72,7 @@ let rec loadfiles ppf name =
     fprintf ppf "File %s loaded@." filename;
     true
   with
-  | Dynlink.Error (Dynlink.Unavailable_unit unit) ->
+  | Compdynlink.Error (Compdynlink.Unavailable_unit unit) ->
       loadfiles ppf (String.uncapitalize_ascii unit ^ ".cmo")
         &&
       loadfiles ppf name
@@ -82,7 +82,7 @@ let rec loadfiles ppf name =
   | Sys_error msg ->
       fprintf ppf "%s: %s@." name msg;
       false
-  | Dynlink.Error e ->
+  | Compdynlink.Error e ->
       raise(Error(Load_failure e))
 
 let loadfile ppf name =
@@ -94,8 +94,8 @@ let loadfile ppf name =
 
 let rec eval_path = function
     Pident id -> Symtable.get_global_value id
-  | Pdot(p, s, pos) -> Obj.field (eval_path p) pos
-  | Papply(p1, p2) -> fatal_error "Loadprinter.eval_path"
+  | Pdot(p, _, pos) -> Obj.field (eval_path p) pos
+  | Papply _ -> fatal_error "Loadprinter.eval_path"
 
 (* Install, remove a printer (as in toplevel/topdirs) *)
 
@@ -109,7 +109,7 @@ let () =
   ignore (Env.read_signature "Topdirs" topdirs)
 
 let match_printer_type desc typename =
-  let (printer_type, _) =
+  let printer_type =
     try
       Env.lookup_type (Ldot(Lident "Topdirs", typename)) Env.empty
     with Not_found ->
@@ -146,13 +146,13 @@ let install_printer ppf lid =
       raise(Error(Unavailable_module(s, lid))) in
   let print_function =
     if is_old_style then
-      (fun formatter repr -> Obj.obj v (Obj.obj repr))
+      (fun _formatter repr -> Obj.obj v (Obj.obj repr))
     else
       (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
   Printval.install_printer path ty_arg ppf print_function
 
 let remove_printer lid =
-  let (ty_arg, path, is_old_style) = find_printer_type lid in
+  let (_ty_arg, path, _is_old_style) = find_printer_type lid in
   try
     Printval.remove_printer path
   with Not_found ->
@@ -165,7 +165,7 @@ open Format
 let report_error ppf = function
   | Load_failure e ->
       fprintf ppf "@[Error during code loading: %s@]@."
-        (Dynlink.error_message e)
+        (Compdynlink.error_message e)
   | Unbound_identifier lid ->
       fprintf ppf "@[Unbound identifier %a@]@."
       Printtyp.longident lid

diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli
index 8fc6f7a6da63196e79c509ea84bffe542a54f8cd..c645e8d21144b9beb5c536828542be1269adfe07 100644 (file)
--- a/debugger/loadprinter.mli
+++ b/debugger/loadprinter.mli
@@ -24,7 +24,7 @@ val remove_printer : Longident.t -> unit
 (* Error report *)
 
 type error =
-  | Load_failure of Dynlink.error
+  | Load_failure of Compdynlink.error
   | Unbound_identifier of Longident.t
   | Unavailable_module of string * Longident.t
   | Wrong_type of Longident.t

diff --git a/debugger/main.ml b/debugger/main.ml
index 50ffcf5c009bcd830d7e298cbd4f6bf371cd4b27..4f2b830f4df4d447209083247eef72e8214a9423 100644 (file)
--- a/debugger/main.ml
+++ b/debugger/main.ml
@@ -29,7 +29,7 @@ open Primitives
 
 let line_buffer = Lexing.from_function read_user_input
 
-let rec loop ppf = line_loop ppf line_buffer
+let loop ppf = line_loop ppf line_buffer
 
 let current_duration = ref (-1L)
 

diff --git a/debugger/parameters.ml b/debugger/parameters.ml
index f9192a7ad0ed7d4b9743c154af18096a77f72c96..a4d647c49809ac1f210beec1493544a1d8da8938 100644 (file)
--- a/debugger/parameters.ml
+++ b/debugger/parameters.ml
@@ -20,7 +20,6 @@ open Primitives
 open Config
 open Debugger_config
 
-let program_loaded = ref false
 let program_name = ref ""
 let socket_name = ref ""
 let arguments = ref ""

diff --git a/debugger/parser.mly b/debugger/parser.mly
index 060aee74b19e109302c61919e6ab2e1e22ac9f6c..36864b042faa74234ee26a78439d2b3ddd2dcc41 100644 (file)
--- a/debugger/parser.mly
+++ b/debugger/parser.mly
@@ -31,7 +31,7 @@ open Parser_aux
 %token          STAR                    /* *  */
 %token          MINUS                   /* -  */
 %token          DOT                     /* . */
-%token          SHARP                   /* #  */
+%token          HASH                    /* #  */
 %token          AT                      /* @  */
 %token          DOLLAR                  /* $ */
 %token          BANG                    /* ! */
@@ -238,7 +238,7 @@ break_argument_eol :
   | integer_eol                                 { BA_pc $1 }
   | expression end_of_line                      { BA_function $1 }
   | AT opt_longident INTEGER opt_integer_eol    { BA_pos1 ($2, (to_int $3), $4)}
-  | AT opt_longident SHARP integer_eol          { BA_pos2 ($2, $4) }
+  | AT opt_longident HASH integer_eol           { BA_pos2 ($2, $4) }
 ;
 
 /* Arguments for list */

diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli
index a218a10400a436ba6d0bb4046a00d704f8c53853..67c844627868a7a16f5f25c05e2bb0a85540de30 100644 (file)
--- a/debugger/parser_aux.mli
+++ b/debugger/parser_aux.mli
@@ -14,10 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(*open Globals*)
-
-open Primitives
-
 type expression =
     E_ident of Longident.t              (* x or Mod.x *)
   | E_name of int                       (* $xxx *)

diff --git a/debugger/pos.ml b/debugger/pos.ml
index 7546df502a159cd76a4e8426d10f72aef92aad2f..cc164e68daef8cd7a7d36c88396425971229e2d6 100644 (file)
--- a/debugger/pos.ml
+++ b/debugger/pos.ml
@@ -16,8 +16,6 @@
 open Instruct;;
 open Lexing;;
 open Location;;
-open Primitives;;
-open Source;;
 
 let get_desc ev =
   let loc = ev.ev_loc in

diff --git a/debugger/primitives.ml b/debugger/primitives.ml
index 498a8c5496f414a46bb425284e37ae85a6565bbc..ac69513714bbbd57ebe5918b943d9048d25bf6e9 100644 (file)
--- a/debugger/primitives.ml
+++ b/debugger/primitives.ml
@@ -95,23 +95,6 @@ let isprefix s1 s2 =
   let l1 = String.length s1 and l2 = String.length s2 in
   (l1 = l2 && s1 = s2) || (l1 < l2 && s1 = String.sub s2 0 l1)
 
-(* Split a string at the given delimiter char *)
-
-let split_string sep str =
-  let rec split i j =
-    if j >= String.length str then
-      if i >= j then [] else [String.sub str i (j-i)]
-    else if str.[j] = sep then
-      if i >= j
-      then skip_sep (j+1)
-      else String.sub str i (j-i) :: skip_sep (j+1)
-    else
-      split i (j+1)
-  and skip_sep j =
-    if j < String.length str && str.[j] = sep
-    then skip_sep (j+1)
-    else split j j
-  in split 0 0
 
 (*** I/O channels ***)
 

diff --git a/debugger/primitives.mli b/debugger/primitives.mli
index f977b49803c4e8f1a767acc1c2ba24d8d535d1c1..2be9032f9fa440e5155c3c792d0e15a4a3d8b390 100644 (file)
--- a/debugger/primitives.mli
+++ b/debugger/primitives.mli
@@ -50,9 +50,6 @@ val string_trim : string -> string
 (* isprefix s1 s2 returns true if s1 is a prefix of s2. *)
 val isprefix : string -> string -> bool
 
-(* Split a string at the given delimiter char *)
-val split_string : char -> string -> string list
-
 (*** I/O channels ***)
 
 type io_channel = {

diff --git a/debugger/printval.ml b/debugger/printval.ml
index 30f111eacacf5d7f22563e29285293241f746583..1175a96c775aea508ef2ff8aada5bb6b7b65f1d7 100644 (file)
--- a/debugger/printval.ml
+++ b/debugger/printval.ml
@@ -40,7 +40,7 @@ let name_value v ty =
 let find_named_value name =
   Hashtbl.find named_values name
 
-let check_depth ppf depth obj ty =
+let check_depth depth obj ty =
   if depth <= 0 then begin
     let n = name_value obj ty in
     Some (Outcometree.Oval_stuff ("$" ^ string_of_int n))
@@ -57,19 +57,19 @@ module EvalPath =
         with Symtable.Error _ ->
           raise Error
         end
-    | Pdot(root, fieldname, pos) ->
+    | Pdot(root, _fieldname, pos) ->
         let v = eval_path env root in
         if not (Debugcom.Remote_value.is_block v)
         then raise Error
         else Debugcom.Remote_value.field v pos
-    | Papply(p1, p2) ->
+    | Papply _ ->
         raise Error
     let same_value = Debugcom.Remote_value.same
   end
 
 module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath)
 
-let install_printer path ty ppf fn =
+let install_printer path ty _ppf fn =
   Printer.install_printer path ty
     (fun ppf remote_val ->
        try
@@ -90,7 +90,7 @@ let print_exception ppf obj =
 let print_value max_depth env obj (ppf : Format.formatter) ty =
   let t =
     Printer.outval_of_value !max_printer_steps max_depth
-      (check_depth ppf) env obj ty in
+      check_depth env obj ty in
   !Oprint.out_value ppf t
 
 let print_named_value max_depth exp env obj ppf ty =

diff --git a/debugger/source.ml b/debugger/source.ml
index 4ab79363c09cf5bf170dae768dd8cef776e7799f..ff41e3fcafeef5fdcead38ce8277c02d1476f20c 100644 (file)
--- a/debugger/source.ml
+++ b/debugger/source.ml
@@ -67,8 +67,6 @@ type buffer = string * (int * int) list ref
 
 let buffer_max_count = ref 10
 
-let cache_size = 30
-
 let buffer_list =
   ref ([] : (string * buffer) list)
 
@@ -101,7 +99,7 @@ let insert_pos buffer ((position, line) as pair) =
     function
       [] ->
         [(position, line)]
-    | ((pos, lin) as a::l) as l' ->
+    | ((_pos, lin) as a::l) as l' ->
         if lin < line then
           pair::l'
         else if lin = line then
@@ -141,13 +139,13 @@ let line_of_pos buffer position =
           raise Out_of_range
         else
           (0, 1)
-    | ((pos, line) as pair)::l ->
+    | ((pos, _line) as pair)::l ->
         if pos > position then
           find l
         else
           pair
   and find_line previous =
-    let (pos, line) as next = next_line buffer previous in
+    let (pos, _line) as next = next_line buffer previous in
       if pos <= position then
         find_line next
       else
@@ -166,7 +164,7 @@ let pos_of_line buffer line =
           raise Out_of_range
         else
           (0, 1)
-    | ((pos, lin) as pair)::l ->
+    | ((_pos, lin) as pair)::l ->
         if lin > line then
           find l
         else

diff --git a/debugger/symbols.ml b/debugger/symbols.ml
index 9a9c8f9c6da5e662ab77cbd15b39890a6bbf821a..dd20d8f9133f30b14090ddc17451a8bbf07ecfe2 100644 (file)
--- a/debugger/symbols.ml
+++ b/debugger/symbols.ml
@@ -62,7 +62,7 @@ let read_symbols' bytecode_file =
   let num_eventlists = input_binary_int ic in
   let dirs = ref StringSet.empty in
   let eventlists = ref [] in
-  for i = 1 to num_eventlists do
+  for _i = 1 to num_eventlists do
     let orig = input_binary_int ic in
     let evl = (input_value ic : debug_event list) in
     (* Relocate events in event list *)
@@ -182,7 +182,7 @@ let event_near_pos md char =
 (* Flip "event" bit on all instructions *)
 let set_all_events () =
   Hashtbl.iter
-    (fun pc ev ->
+    (fun _pc ev ->
        match ev.ev_kind with
          Event_pseudo -> ()
        | _            -> Debugcom.set_event ev.ev_pos)

diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml
index c7d6e9a8d8a8c574b9a2e0dc2774ffadd63f0e68..ec72413b07ea8778a6a819d03ae985faf132efc5 100644 (file)
--- a/debugger/time_travel.ml
+++ b/debugger/time_travel.ml
@@ -271,7 +271,7 @@ let rec stop_on_event report =
         None   -> find_event ()
       | Some _ -> ()
       end
-  | {rep_type = Trap_barrier; rep_stack_pointer = trap_frame} ->
+  | {rep_type = Trap_barrier} ->
       (* No event at current position. *)
       find_event ()
   | _ ->
@@ -452,7 +452,7 @@ let go_to time =
 
 (* Return the time of the last breakpoint *)
 (* between current time and `max_time'. *)
-let rec find_last_breakpoint max_time =
+let find_last_breakpoint max_time =
   let rec find break =
     let time = current_time () in
     step_forward (max_time -- time);
@@ -559,14 +559,14 @@ let next_1 () =
     None ->                             (* Beginning of the program. *)
       step _1
   | Some event1 ->
-      let (frame1, pc1) = initial_frame() in
+      let (frame1, _pc1) = initial_frame() in
       step _1;
       if not !interrupted then begin
         Symbols.update_current_event ();
         match !current_event with
           None -> ()
         | Some event2 ->
-            let (frame2, pc2) = initial_frame() in
+            let (frame2, _pc2) = initial_frame() in
             (* Call `finish' if we've entered a function. *)
             if frame1 >= 0 && frame2 >= 0 &&
                frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize
@@ -627,14 +627,14 @@ let previous_1 () =
     None ->                             (* End of the program. *)
       step _minus1
   | Some event1 ->
-      let (frame1, pc1) = initial_frame() in
+      let (frame1, _pc1) = initial_frame() in
       step _minus1;
       if not !interrupted then begin
         Symbols.update_current_event ();
         match !current_event with
           None -> ()
         | Some event2 ->
-            let (frame2, pc2) = initial_frame() in
+            let (frame2, _pc2) = initial_frame() in
             (* Call `start' if we've entered a function. *)
             if frame1 >= 0 && frame2 >= 0 &&
                frame2 - event2.ev_stacksize > frame1 - event1.ev_stacksize

diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml
index faf5fb7b07d04833693a44f84fae18b489b2ef77..4771253b0d8011759e2a220cc7b41eda25b4f58d 100644 (file)
--- a/debugger/unix_tools.ml
+++ b/debugger/unix_tools.ml
@@ -18,7 +18,6 @@
 
 open Misc
 open Unix
-open Primitives
 
 (*** Convert a socket name into a socket address. ***)
 let convert_address address =

diff --git a/driver/compdynlink.mlno b/driver/compdynlink.mlno
new file mode 100644 (file)
index 0000000..d7d685b
--- /dev/null
+++ b/driver/compdynlink.mlno
@@ -0,0 +1,57 @@
+#2 "driver/compdynlink.mlno"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Dynamic loading of .cmx files *)
+
+type linking_error =
+    Undefined_global of string
+  | Unavailable_primitive of string
+  | Uninitialized_global of string
+
+type error =
+    Not_a_bytecode_file of string
+  | Inconsistent_import of string
+  | Unavailable_unit of string
+  | Unsafe_file
+  | Linking_error of string * linking_error
+  | Corrupted_interface of string
+  | File_not_found of string
+  | Cannot_open_dll of string
+  | Inconsistent_implementation of string
+
+exception Error of error
+
+let not_available _ =
+  failwith "No support for native dynlink on this OS"
+
+let default_available_units = not_available
+
+let init = not_available
+
+let loadfile = not_available
+let loadfile_private = not_available
+let allow_only = not_available
+let prohibit = not_available
+
+let digest_interface = not_available
+let add_interfaces = not_available
+let add_available_units = not_available
+let clear_available_units = not_available
+let allow_unsafe_modules = not_available
+let error_message = not_available
+
+let is_native = true
+let adapt_filename f = Filename.chop_extension f ^ ".cmxs"

diff --git a/driver/compenv.ml b/driver/compenv.ml
index cbdb59c41fff33997cdf45a97cc2acbc6ca76283..c829820c526ab4c216633acb514e8d9837464d5b 100644 (file)
--- a/driver/compenv.ml
+++ b/driver/compenv.ml
@@ -20,7 +20,7 @@ let output_prefix name =
     match !output_name with
     | None -> name
     | Some n -> if !compile_only then (output_name := None; n) else name in
-  Misc.chop_extension_if_any oname
+  Filename.remove_extension oname
 
 let print_version_and_library compiler =
   Printf.printf "The OCaml %s, version " compiler;
@@ -106,7 +106,7 @@ type readenv_position =
 exception SyntaxError of string
 
 let parse_args s =
-  let args = Misc.split s ',' in
+  let args = String.split_on_char ',' s in
   let rec iter is_after args before after =
     match args with
       [] ->
@@ -158,6 +158,7 @@ let int_option_setter ppf name option s =
       (Warnings.Bad_env_variable
          ("OCAMLPARAM", Printf.sprintf "non-integer parameter for \"%s\"" name))
 
+(*
 let float_setter ppf name option s =
   try
     option := float_of_string s
@@ -165,6 +166,9 @@ let float_setter ppf name option s =
     Location.print_warning Location.none ppf
       (Warnings.Bad_env_variable
          ("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name))
+*)
+
+let load_plugin = ref (fun _ -> ())
 
 let check_bool ppf name s =
   match s with
@@ -201,6 +205,7 @@ let read_one_param ppf position name v =
   | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v
   | "strict-formats" -> set "strict-formats" [ strict_formats ] v
   | "thread" -> set "thread" [ use_threads ] v
+  | "unboxed-types" -> set "unboxed-types" [ unboxed_types ] v
   | "unsafe" -> set "unsafe" [ fast ] v
   | "verbose" -> set "verbose" [ verbose ] v
   | "nopervasives" -> set "nopervasives" [ nopervasives ] v
@@ -398,6 +403,8 @@ let read_one_param ppf position name v =
 
   | "timings" -> set "timings" [ print_timings ] v
 
+  | "plugin" -> !load_plugin v
+
   | _ ->
     if not (List.mem name !can_discard) then begin
       can_discard := name :: !can_discard;
@@ -520,5 +527,109 @@ let readenv ppf position =
   all_ccopts := !last_ccopts @ !first_ccopts;
   all_ppx := !last_ppx @ !first_ppx
 
-let get_objfiles () =
-  List.rev (!last_objfiles @ !objfiles @ !first_objfiles)
+let get_objfiles ~with_ocamlparam =
+  if with_ocamlparam then
+    List.rev (!last_objfiles @ !objfiles @ !first_objfiles)
+  else
+    List.rev !objfiles
+
+
+
+
+
+
+type deferred_action =
+  | ProcessImplementation of string
+  | ProcessInterface of string
+  | ProcessCFile of string
+  | ProcessOtherFile of string
+  | ProcessObjects of string list
+  | ProcessDLLs of string list
+
+let c_object_of_filename name =
+  Filename.chop_suffix (Filename.basename name) ".c" ^ Config.ext_obj
+
+let process_action
+    (ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action =
+  match action with
+  | ProcessImplementation name ->
+      readenv ppf (Before_compile name);
+      let opref = output_prefix name in
+      implementation ppf name opref;
+      objfiles := (opref ^ ocaml_mod_ext) :: !objfiles
+  | ProcessInterface name ->
+      readenv ppf (Before_compile name);
+      let opref = output_prefix name in
+      interface ppf name opref;
+      if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
+  | ProcessCFile name ->
+      readenv ppf (Before_compile name);
+      Location.input_name := name;
+      if Ccomp.compile_file name <> 0 then exit 2;
+      ccobjs := c_object_of_filename name :: !ccobjs
+  | ProcessObjects names ->
+      ccobjs := names @ !ccobjs
+  | ProcessDLLs names ->
+      dllibs := names @ !dllibs
+  | ProcessOtherFile name ->
+      if Filename.check_suffix name ocaml_mod_ext
+      || Filename.check_suffix name ocaml_lib_ext then
+        objfiles := name :: !objfiles
+      else if Filename.check_suffix name ".cmi" && !make_package then
+        objfiles := name :: !objfiles
+      else if Filename.check_suffix name Config.ext_obj
+           || Filename.check_suffix name Config.ext_lib then
+        ccobjs := name :: !ccobjs
+      else if not !native_code && Filename.check_suffix name Config.ext_dll then
+        dllibs := name :: !dllibs
+      else
+        raise(Arg.Bad("don't know what to do with " ^ name))
+
+
+let action_of_file name =
+  if Filename.check_suffix name ".ml"
+  || Filename.check_suffix name ".mlt" then
+    ProcessImplementation name
+  else if Filename.check_suffix name !Config.interface_suffix then
+    ProcessInterface name
+  else if Filename.check_suffix name ".c" then
+    ProcessCFile name
+  else
+    ProcessOtherFile name
+
+let deferred_actions = ref []
+let defer action =
+  deferred_actions := action :: !deferred_actions
+
+let anonymous filename = defer (action_of_file filename)
+let impl filename = defer (ProcessImplementation filename)
+let intf filename = defer (ProcessInterface filename)
+
+let process_deferred_actions env =
+  let final_output_name = !output_name in
+  (* Make sure the intermediate products don't clash with the final one
+     when we're invoked like: ocamlopt -o foo bar.c baz.ml. *)
+  if not !compile_only then output_name := None;
+  begin
+    match final_output_name with
+    | None -> ()
+    | Some output_name ->
+        if !compile_only then begin
+          if List.filter (function
+              | ProcessCFile name -> c_object_of_filename name <> output_name
+              | _ -> false) !deferred_actions <> [] then
+            fatal "Options -c and -o are incompatible when compiling C files";
+
+          if List.length (List.filter (function
+              | ProcessImplementation _
+              | ProcessInterface _
+              | _ -> false) !deferred_actions) > 1 then
+            fatal "Options -c -o are incompatible with compiling multiple files"
+        end;
+  end;
+  if !make_archive && List.exists (function
+      | ProcessOtherFile name -> Filename.check_suffix name ".cmxa"
+      | _ -> false) !deferred_actions then
+    fatal "Option -a cannot be used with .cmxa input files.";
+  List.iter (process_action env) (List.rev !deferred_actions);
+  output_name := final_output_name;

diff --git a/driver/compenv.mli b/driver/compenv.mli
index 413420d422a0581a3be326cbeff62402b25549e3..0ee9871a6ce89331a9e2711ed3d583a2c60c19d9 100644 (file)
--- a/driver/compenv.mli
+++ b/driver/compenv.mli
@@ -30,8 +30,13 @@ val first_include_dirs : string list ref
 val last_include_dirs : string list ref
 val implicit_modules : string list ref
 
+(* function to call on plugin=XXX *)
+val load_plugin : (string -> unit) ref
+
 (* return the list of objfiles, after OCAMLPARAM and List.rev *)
-val get_objfiles : unit -> string list
+val get_objfiles : with_ocamlparam:bool -> string list
+val last_objfiles : string list ref
+val first_objfiles : string list ref
 
 type filename = string
 
@@ -46,3 +51,28 @@ val is_unit_name : string -> bool
 (* [check_unit_name ppf filename name] prints a warning in [filename]
    on [ppf] if [name] should not be used as a module name. *)
 val check_unit_name : Format.formatter -> string -> string -> unit
+
+(* Deferred actions of the compiler, while parsing arguments *)
+
+type deferred_action =
+  | ProcessImplementation of string
+  | ProcessInterface of string
+  | ProcessCFile of string
+  | ProcessOtherFile of string
+  | ProcessObjects of string list
+  | ProcessDLLs of string list
+
+val c_object_of_filename : string -> string
+
+val defer : deferred_action -> unit
+val anonymous : string -> unit
+val impl : string -> unit
+val intf : string -> unit
+
+val process_deferred_actions :
+  Format.formatter *
+  (Format.formatter -> string -> string -> unit) * (* compile implementation *)
+  (Format.formatter -> string -> string -> unit) * (* compile interface *)
+  string * (* ocaml module extension *)
+  string -> (* ocaml library extension *)
+  unit

diff --git a/driver/compile.ml b/driver/compile.ml
index 053327f21d45309e9e66c2f54c0b00c5e8a0b53b..0d7325d331567e4aa49858b7e9405e211802dbd8 100644 (file)
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -32,9 +32,10 @@ let interface ppf sourcefile outputprefix =
   Env.set_unit_name modulename;
   let initial_env = Compmisc.initial_env () in
   let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
+
   if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
   if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
-  let tsg = Typemod.type_interface initial_env ast in
+  let tsg = Typemod.type_interface sourcefile initial_env ast in
   if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
   let sg = tsg.sig_type in
   if !Clflags.print_types then
@@ -75,29 +76,30 @@ let implementation ppf sourcefile outputprefix =
           (Typemod.type_implementation sourcefile outputprefix modulename env)
       ++ print_if ppf Clflags.dump_typedtree
         Printtyped.implementation_with_coercion
-    in
+   in
     if !Clflags.print_types then begin
       Warnings.check_fatal ();
       Stypes.dump (Some (outputprefix ^ ".annot"))
     end else begin
-      let bytecode =
+      let bytecode, required_globals =
         (typedtree, coercion)
         ++ Timings.(time (Transl sourcefile))
             (Translmod.transl_implementation modulename)
-        ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
         ++ Timings.(accumulate_time (Generate sourcefile))
-            (fun lambda ->
-              Simplif.simplify_lambda lambda
+            (fun { Lambda.code = lambda; required_globals } ->
+              print_if ppf Clflags.dump_rawlambda Printlambda.lambda lambda
+              ++ Simplif.simplify_lambda sourcefile
               ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
               ++ Bytegen.compile_implementation modulename
-              ++ print_if ppf Clflags.dump_instr Printinstr.instrlist)
+              ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
+              ++ fun bytecode -> bytecode, required_globals)
       in
       let objfile = outputprefix ^ ".cmo" in
       let oc = open_out_bin objfile in
       try
         bytecode
         ++ Timings.(accumulate_time (Generate sourcefile))
-            (Emitcode.to_file oc modulename objfile);
+            (Emitcode.to_file oc modulename objfile ~required_globals);
         Warnings.check_fatal ();
         close_out oc;
         Stypes.dump (Some (outputprefix ^ ".annot"))
@@ -109,7 +111,3 @@ let implementation ppf sourcefile outputprefix =
   with x ->
     Stypes.dump (Some (outputprefix ^ ".annot"));
     raise x
-
-let c_file name =
-  Location.input_name := name;
-  if Ccomp.compile_file name <> 0 then exit 2

diff --git a/driver/compile.mli b/driver/compile.mli
index 2ae4f7a4a64856d8a71630037c11e43260844bd0..defc101be3fca82c76c07dad546313945ad4b579 100644 (file)
--- a/driver/compile.mli
+++ b/driver/compile.mli
@@ -19,4 +19,3 @@ open Format
 
 val interface: formatter -> string -> string -> unit
 val implementation: formatter -> string -> string -> unit
-val c_file: string -> unit

diff --git a/driver/compmisc.ml b/driver/compmisc.ml
index 27efafd185511dd5066469bbf86f5f3efe010b0f..36a2b81c21f2bc1ba1e4e7855f9d48e4989ba3f6 100644 (file)
--- a/driver/compmisc.ml
+++ b/driver/compmisc.ml
@@ -27,10 +27,9 @@ let init_path ?(dir="") native =
     else if !Clflags.use_vmthreads && not native then
       "+vmthreads" :: !Clflags.include_dirs
     else
-      !last_include_dirs @
-      !Clflags.include_dirs @
-      !first_include_dirs
+      !Clflags.include_dirs
   in
+  let dirs = !last_include_dirs @ dirs @ !first_include_dirs in
   let exp_dirs =
     List.map (Misc.expand_directory Config.standard_library) dirs in
   Config.load_path := dir ::

diff --git a/driver/compplugin.ml b/driver/compplugin.ml
new file mode 100644 (file)
index 0000000..481692c
--- /dev/null
+++ b/driver/compplugin.ml
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A table to avoid double linking of plugins, especially with OCAMLPARAM *)
+let plugins = Hashtbl.create 13
+
+let load plugin_name =
+
+  let plugin_name =
+    try
+      Compdynlink.adapt_filename plugin_name
+    with Invalid_argument _ -> plugin_name
+  in
+
+  let plugin_file =
+    if Filename.is_implicit plugin_name then
+      try
+        Compmisc.init_path !Clflags.native_code;
+        Misc.find_in_path !Config.load_path plugin_name
+      with Not_found ->
+        raise (Compdynlink.Error (Compdynlink.File_not_found plugin_name))
+    else plugin_name
+  in
+
+  if not (Hashtbl.mem plugins plugin_file) then begin
+    Compdynlink.loadfile plugin_file;
+    Hashtbl.add plugins plugin_file (); (* plugin loaded *)
+  end
+
+let () =
+  Location.register_error_of_exn (function
+  | Compdynlink.Error error ->
+    Some (Location.error (
+      Printf.sprintf "%s while loading argument of -plugin"
+        (Compdynlink.error_message error)))
+  | _ -> None);
+  Compenv.load_plugin := load

diff --git a/driver/compplugin.mli b/driver/compplugin.mli
new file mode 100644 (file)
index 0000000..a1103f6
--- /dev/null
+++ b/driver/compplugin.mli
@@ -0,0 +1,16 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Fabrice Le Fessant, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+val load : string -> unit

diff --git a/driver/main.ml b/driver/main.ml
index 3bfd8f3df31e2e9a7614dabf9218ecac9cf9b43f..e9af202ff9f70c32628a51be4e3811e0e48ffcb0 100644 (file)
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -13,60 +13,13 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Config
 open Clflags
 open Compenv
 
-let process_interface_file ppf name =
-  let opref = output_prefix name in
-  Compile.interface ppf name opref;
-  if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
-
-let process_implementation_file ppf name =
-  let opref = output_prefix name in
-  Compile.implementation ppf name opref;
-  objfiles := (opref ^ ".cmo") :: !objfiles
-
-let process_file ppf name =
-  if Filename.check_suffix name ".ml"
-  || Filename.check_suffix name ".mlt" then
-    process_implementation_file ppf name
-  else if Filename.check_suffix name !Config.interface_suffix then
-    process_interface_file ppf name
-  else if Filename.check_suffix name ".cmo"
-       || Filename.check_suffix name ".cma" then
-    objfiles := name :: !objfiles
-  else if Filename.check_suffix name ".cmi" && !make_package then
-    objfiles := name :: !objfiles
-  else if Filename.check_suffix name ext_obj
-       || Filename.check_suffix name ext_lib then
-    ccobjs := name :: !ccobjs
-  else if Filename.check_suffix name ext_dll then
-    dllibs := name :: !dllibs
-  else if Filename.check_suffix name ".c" then begin
-    Compile.c_file name;
-    ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj)
-              :: !ccobjs
-  end
-  else
-    raise(Arg.Bad("don't know what to do with " ^ name))
-
 let usage = "Usage: ocamlc <options> <files>\nOptions are:"
 
-let ppf = Format.err_formatter
-
 (* Error messages to standard error formatter *)
-let anonymous filename =
-  readenv ppf (Before_compile filename);
-  process_file ppf filename;;
-
-let impl filename =
-  readenv ppf (Before_compile filename);
-  process_implementation_file ppf filename;;
-
-let intf filename =
-  readenv ppf (Before_compile filename);
-  process_interface_file ppf filename;;
+let ppf = Format.err_formatter
 
 let show_config () =
   Config.print_config stdout;
@@ -82,13 +35,13 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _binannot = set binary_annotations
   let _c = set compile_only
   let _cc s = c_compiler := Some s
-  let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
+  let _cclib s = Compenv.defer (ProcessObjects (Misc.rev_split_words s))
   let _ccopt s = first_ccopts := s :: !first_ccopts
   let _compat_32 = set bytecode_compatible_32
   let _config = show_config
   let _custom = set custom_runtime
   let _no_check_prims = set no_check_prims
-  let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs
+  let _dllib s = defer (ProcessDLLs (Misc.rev_split_words s))
   let _dllpath s = dllpaths := !dllpaths @ [s]
   let _for_pack s = for_package := Some s
   let _g = set debug
@@ -124,6 +77,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _pack = set make_package
   let _pp s = preprocessor := Some s
   let _ppx s = first_ppx := s :: !first_ppx
+  let _plugin p = Compplugin.load p
   let _principal = set principal
   let _no_principal = unset principal
   let _rectypes = set recursive_types
@@ -137,6 +91,8 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _no_strict_formats = unset strict_formats
   let _thread = set use_threads
   let _vmthread = set use_vmthreads
+  let _unboxed_types = set unboxed_types
+  let _no_unboxed_types = unset unboxed_types
   let _unsafe = set fast
   let _unsafe_string = set unsafe_string
   let _use_prims s = use_prims := s
@@ -169,6 +125,12 @@ let main () =
   try
     readenv ppf Before_args;
     Arg.parse Options.list anonymous usage;
+    Compenv.process_deferred_actions
+      (ppf,
+       Compile.implementation,
+       Compile.interface,
+       ".cmo",
+       ".cma");
     readenv ppf Before_link;
     if
       List.length (List.filter (fun x -> !x)
@@ -182,14 +144,15 @@ let main () =
     if !make_archive then begin
       Compmisc.init_path false;
 
-      Bytelibrarian.create_archive ppf  (Compenv.get_objfiles ())
+      Bytelibrarian.create_archive ppf
+                                   (Compenv.get_objfiles ~with_ocamlparam:false)
                                    (extract_output !output_name);
       Warnings.check_fatal ();
     end
     else if !make_package then begin
       Compmisc.init_path false;
       let extracted_output = extract_output !output_name in
-      let revd = get_objfiles () in
+      let revd = get_objfiles ~with_ocamlparam:false in
       Bytepackager.package_files ppf (Compmisc.initial_env ())
         revd (extracted_output);
       Warnings.check_fatal ();
@@ -212,7 +175,7 @@ let main () =
           default_output !output_name
       in
       Compmisc.init_path false;
-      Bytelink.link ppf (get_objfiles ()) target;
+      Bytelink.link ppf (get_objfiles ~with_ocamlparam:true) target;
       Warnings.check_fatal ();
     end;
   with x ->

diff --git a/driver/main_args.ml b/driver/main_args.ml
index ea89daf33d2eda8f52d0c34b063b72e75e83b3b0..b40d3da5cc35f32cc40ccd54dfc96037c1e02342 100644 (file)
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -228,7 +228,7 @@ let mk_keep_docs f =
 ;;
 
 let mk_no_keep_docs f =
-  "-keep-docs", Arg.Unit f,
+  "-no-keep-docs", Arg.Unit f,
   " Do not keep documentation strings in .cmi files (default)"
 ;;
 
@@ -385,6 +385,11 @@ let mk_ppx f =
   "<command>  Pipe abstract syntax trees through preprocessor <command>"
 ;;
 
+let mk_plugin f =
+  "-plugin", Arg.String f,
+  "<plugin>  Load dynamic plugin <plugin>"
+;;
+
 let mk_principal f =
   "-principal", Arg.Unit f, " Check principality of type inference"
 ;;
@@ -418,7 +423,9 @@ let mk_S f =
 ;;
 
 let mk_safe_string f =
-  "-safe-string", Arg.Unit f, " Make strings immutable"
+  "-safe-string", Arg.Unit f,
+  if Config.safe_string then " Make strings immutable (default)"
+  else " Make strings immutable"
 ;;
 
 let mk_shared f =
@@ -465,13 +472,30 @@ let mk_unbox_closures_factor f =
     Clflags.default_unbox_closures_factor
 ;;
 
+let mk_unboxed_types f =
+  "-unboxed-types", Arg.Unit f,
+  " unannotated unboxable types will be unboxed"
+;;
+
+let mk_no_unboxed_types f =
+  "-no-unboxed-types", Arg.Unit f,
+  " unannotated unboxable types will not be unboxed (default)"
+;;
+
 let mk_unsafe f =
   "-unsafe", Arg.Unit f,
   " Do not compile bounds checking on array and string access"
 ;;
 
 let mk_unsafe_string f =
-  "-unsafe-string", Arg.Unit f, " Make strings mutable (default)"
+  if Config.safe_string then
+    let err () =
+      raise (Arg.Bad "OCaml has been configured with -safe-string: \
+                      -unsafe-string is not available")
+    in
+    "-unsafe-string", Arg.Unit err, " (option not available)"
+  else
+    "-unsafe-string", Arg.Unit f, " Make strings mutable (default)"
 ;;
 
 let mk_use_runtime f =
@@ -501,6 +525,10 @@ let mk__version f =
   "--version", Arg.Unit f, " Print version and exit"
 ;;
 
+let mk_no_version f =
+  "-no-version", Arg.Unit f, " Do not print version at startup"
+;;
+
 let mk_vmthread f =
   "-vmthread", Arg.Unit f,
   " Generate code that supports the threads library with VM-level\n\
@@ -724,6 +752,8 @@ module type Common_options = sig
   val _no_strict_sequence : unit -> unit
   val _strict_formats : unit -> unit
   val _no_strict_formats : unit -> unit
+  val _unboxed_types : unit -> unit
+  val _no_unboxed_types : unit -> unit
   val _unsafe : unit -> unit
   val _unsafe_string : unit -> unit
   val _version : unit -> unit
@@ -767,6 +797,7 @@ module type Compiler_options = sig
   val _output_obj : unit -> unit
   val _output_complete_obj : unit -> unit
   val _pack : unit -> unit
+  val _plugin : string -> unit
   val _pp : string -> unit
   val _principal : unit -> unit
   val _no_principal : unit -> unit
@@ -785,6 +816,18 @@ module type Compiler_options = sig
 end
 ;;
 
+module type Toplevel_options = sig
+  include Common_options
+  val _init : string -> unit
+  val _noinit : unit -> unit
+  val _no_version : unit -> unit
+  val _noprompt : unit -> unit
+  val _nopromptcont : unit -> unit
+  val _plugin : string -> unit
+  val _stdin : unit -> unit
+end
+;;
+
 module type Bytecomp_options = sig
   include Common_options
   include Compiler_options
@@ -803,13 +846,7 @@ module type Bytecomp_options = sig
 end;;
 
 module type Bytetop_options = sig
-  include Common_options
-  val _init : string -> unit
-  val _noinit : unit -> unit
-  val _noprompt : unit -> unit
-  val _nopromptcont : unit -> unit
-  val _stdin : unit -> unit
-
+  include Toplevel_options
   val _dinstr : unit -> unit
 end;;
 
@@ -875,14 +912,10 @@ module type Optcomp_options = sig
 end;;
 
 module type Opttop_options = sig
-  include Common_options
+  include Toplevel_options
   include Optcommon_options
-  val _init : string -> unit
-  val _noinit : unit -> unit
-  val _noprompt : unit -> unit
-  val _nopromptcont : unit -> unit
+  val _verbose : unit -> unit
   val _S : unit -> unit
-  val _stdin : unit -> unit
 end;;
 
 module type Ocamldoc_options = sig
@@ -957,6 +990,7 @@ struct
     mk_pack_byt F._pack;
     mk_pp F._pp;
     mk_ppx F._ppx;
+    mk_plugin F._plugin;
     mk_principal F._principal;
     mk_no_principal F._no_principal;
     mk_rectypes F._rectypes;
@@ -969,6 +1003,8 @@ struct
     mk_strict_formats F._strict_formats;
     mk_no_strict_formats F._no_strict_formats;
     mk_thread F._thread;
+    mk_unboxed_types F._unboxed_types;
+    mk_no_unboxed_types F._no_unboxed_types;
     mk_unsafe F._unsafe;
     mk_unsafe_string F._unsafe_string;
     mk_use_runtime F._use_runtime;
@@ -1016,6 +1052,7 @@ struct
     mk_nostdlib F._nostdlib;
     mk_open F._open;
     mk_ppx F._ppx;
+    mk_plugin F._plugin;
     mk_principal F._principal;
     mk_no_principal F._no_principal;
     mk_rectypes F._rectypes;
@@ -1027,10 +1064,13 @@ struct
     mk_no_strict_sequence F._no_strict_sequence;
     mk_strict_formats F._strict_formats;
     mk_no_strict_formats F._no_strict_formats;
+    mk_unboxed_types F._unboxed_types;
+    mk_no_unboxed_types F._no_unboxed_types;
     mk_unsafe F._unsafe;
     mk_unsafe_string F._unsafe_string;
     mk_version F._version;
     mk__version F._version;
+    mk_no_version F._no_version;
     mk_vnum F._vnum;
     mk_w F._w;
     mk_warn_error F._warn_error;
@@ -1108,6 +1148,7 @@ struct
     mk_output_complete_obj F._output_complete_obj;
     mk_p F._p;
     mk_pack_opt F._pack;
+    mk_plugin F._plugin;
     mk_pp F._pp;
     mk_ppx F._ppx;
     mk_principal F._principal;
@@ -1129,6 +1170,8 @@ struct
     mk_unbox_closures F._unbox_closures;
     mk_unbox_closures_factor F._unbox_closures_factor;
     mk_inline_max_unroll F._inline_max_unroll;
+    mk_unboxed_types F._unboxed_types;
+    mk_no_unboxed_types F._no_unboxed_types;
     mk_unsafe F._unsafe;
     mk_unsafe_string F._unsafe_string;
     mk_v F._v;
@@ -1209,6 +1252,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_o2 F._o2;
     mk_o3 F._o3;
     mk_open F._open;
+    mk_plugin F._plugin;
     mk_ppx F._ppx;
     mk_principal F._principal;
     mk_no_principal F._no_principal;
@@ -1225,10 +1269,14 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_no_strict_formats F._no_strict_formats;
     mk_unbox_closures F._unbox_closures;
     mk_unbox_closures_factor F._unbox_closures_factor;
+    mk_unboxed_types F._unboxed_types;
+    mk_no_unboxed_types F._no_unboxed_types;
     mk_unsafe F._unsafe;
     mk_unsafe_string F._unsafe_string;
+    mk_verbose F._verbose;
     mk_version F._version;
     mk__version F._version;
+    mk_no_version F._no_version;
     mk_vnum F._vnum;
     mk_w F._w;
     mk_warn_error F._warn_error;
@@ -1293,6 +1341,8 @@ struct
     mk_strict_formats F._strict_formats;
     mk_no_strict_formats F._no_strict_formats;
     mk_thread F._thread;
+    mk_unboxed_types F._unboxed_types;
+    mk_no_unboxed_types F._no_unboxed_types;
     mk_unsafe_string F._unsafe_string;
     mk_v F._v;
     mk_verbose F._verbose;

diff --git a/driver/main_args.mli b/driver/main_args.mli
index 49de50d52a087857d1b528435ed3e2e095077af5..b5b0eaaedb84cd2f3cbc9016f75a0b62ef3a3674 100644 (file)
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -39,6 +39,8 @@ module type Common_options = sig
   val _no_strict_sequence : unit -> unit
   val _strict_formats : unit -> unit
   val _no_strict_formats : unit -> unit
+  val _unboxed_types : unit -> unit
+  val _no_unboxed_types : unit -> unit
   val _unsafe : unit -> unit
   val _unsafe_string : unit -> unit
   val _version : unit -> unit
@@ -82,6 +84,7 @@ module type Compiler_options = sig
   val _output_obj : unit -> unit
   val _output_complete_obj : unit -> unit
   val _pack : unit -> unit
+  val _plugin : string -> unit
   val _pp : string -> unit
   val _principal : unit -> unit
   val _no_principal : unit -> unit
@@ -100,6 +103,18 @@ module type Compiler_options = sig
 end
 ;;
 
+module type Toplevel_options = sig
+  include Common_options
+  val _init : string -> unit
+  val _noinit : unit -> unit
+  val _no_version : unit -> unit
+  val _noprompt : unit -> unit
+  val _nopromptcont : unit -> unit
+  val _plugin : string -> unit
+  val _stdin : unit -> unit
+end
+;;
+
 module type Bytecomp_options = sig
   include Common_options
   include Compiler_options
@@ -118,13 +133,7 @@ module type Bytecomp_options = sig
 end;;
 
 module type Bytetop_options = sig
-  include Common_options
-  val _init : string -> unit
-  val _noinit : unit -> unit
-  val _noprompt : unit -> unit
-  val _nopromptcont : unit -> unit
-  val _stdin : unit -> unit
-
+  include Toplevel_options
   val _dinstr : unit -> unit
 end;;
 
@@ -190,14 +199,10 @@ module type Optcomp_options = sig
 end;;
 
 module type Opttop_options = sig
-  include Common_options
+  include Toplevel_options
   include Optcommon_options
-  val _init : string -> unit
-  val _noinit : unit -> unit
-  val _noprompt : unit -> unit
-  val _nopromptcont : unit -> unit
+  val _verbose : unit -> unit
   val _S : unit -> unit
-  val _stdin : unit -> unit
 end;;
 
 module type Ocamldoc_options = sig

diff --git a/driver/optcompile.ml b/driver/optcompile.ml
index 00e424bc0f5a30760db581318147c1a97c4117e7..991b9f5216a1596cec14e1f336d1043219357add 100644 (file)
--- a/driver/optcompile.ml
+++ b/driver/optcompile.ml
@@ -35,7 +35,7 @@ let interface ppf sourcefile outputprefix =
   let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
   if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
   if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
-  let tsg = Typemod.type_interface initial_env ast in
+  let tsg = Typemod.type_interface sourcefile initial_env ast in
   if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
   let sg = tsg.sig_type in
   if !Clflags.print_types then
@@ -63,7 +63,7 @@ let print_if ppf flag printer arg =
 let (++) x f = f x
 let (+++) (x, y) f = (x, f y)
 
-let implementation ppf sourcefile outputprefix ~backend =
+let implementation ~backend ppf sourcefile outputprefix =
   let source_provenance = Timings.File sourcefile in
   Compmisc.init_path true;
   let modulename = module_of_filename ppf sourcefile outputprefix in
@@ -93,10 +93,12 @@ let implementation ppf sourcefile outputprefix ~backend =
         (typedtree, coercion)
         ++ Timings.(time (Timings.Transl sourcefile)
             (Translmod.transl_implementation_flambda modulename))
-        +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
-        ++ Timings.time (Timings.Generate sourcefile) (fun lambda ->
-          lambda
-          +++ Simplif.simplify_lambda
+        ++ Timings.time (Timings.Generate sourcefile)
+          (fun { Lambda.module_ident; main_module_block_size;
+                 required_globals; code } ->
+          ((module_ident, main_module_block_size), code)
+          +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+          +++ Simplif.simplify_lambda sourcefile
           +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
           ++ (fun ((module_ident, size), lam) ->
               Middle_end.middle_end ppf ~source_provenance
@@ -107,7 +109,7 @@ let implementation ppf sourcefile outputprefix ~backend =
                 ~backend
                 ~module_initializer:lam)
           ++ Asmgen.compile_implementation_flambda ~source_provenance
-            outputprefix ~backend ppf;
+            outputprefix ~required_globals ~backend ppf;
           Compilenv.save_unit_info cmxfile)
       end
       else begin
@@ -117,9 +119,10 @@ let implementation ppf sourcefile outputprefix ~backend =
             (Translmod.transl_store_implementation modulename)
         ++ print_if ppf Clflags.dump_rawlambda Printlambda.program
         ++ Timings.(time (Generate sourcefile))
-            (fun { Lambda.code; main_module_block_size } ->
-              { Lambda.code = Simplif.simplify_lambda code;
-                main_module_block_size }
+            (fun program ->
+              { program with
+                Lambda.code = Simplif.simplify_lambda sourcefile
+                  program.Lambda.code }
               ++ print_if ppf Clflags.dump_lambda Printlambda.program
               ++ Asmgen.compile_implementation_clambda ~source_provenance
                 outputprefix ppf;
@@ -135,6 +138,3 @@ let implementation ppf sourcefile outputprefix ~backend =
     remove_file objfile;
     remove_file cmxfile;
     raise x
-
-let c_file name =
-  if Ccomp.compile_file name <> 0 then exit 2

diff --git a/driver/optcompile.mli b/driver/optcompile.mli
index 8c6865da1d23ae37abb4b0fc7363ac469e2880fa..3f3081383d990bb441fee807e9551896e2afa79c 100644 (file)
--- a/driver/optcompile.mli
+++ b/driver/optcompile.mli
@@ -19,11 +19,9 @@ open Format
 
 val interface: formatter -> string -> string -> unit
 
-val implementation
-   : formatter
+val implementation:
+   backend:(module Backend_intf.S)
+   -> formatter
   -> string
   -> string
-  -> backend:(module Backend_intf.S)
   -> unit
-
-val c_file: string -> unit

diff --git a/driver/optmain.ml b/driver/optmain.ml
index 8d1d3dd301dc48fadeb14337c1bf1bd7d8faff57..2c6d60e974edd4bd1b6f652a8b26e7cbb0083f6f 100644 (file)
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -13,7 +13,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Config
 open Clflags
 open Compenv
 
@@ -35,59 +34,8 @@ module Backend = struct
 end
 let backend = (module Backend : Backend_intf.S)
 
-let process_interface_file ppf name =
-  let opref = output_prefix name in
-  Optcompile.interface ppf name opref;
-  if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
-
-let process_implementation_file ppf name =
-  let opref = output_prefix name in
-  Optcompile.implementation ppf name opref ~backend;
-  objfiles := (opref ^ ".cmx") :: !objfiles
-
-let cmxa_present = ref false;;
-
-let process_file ppf name =
-  if Filename.check_suffix name ".ml"
-  || Filename.check_suffix name ".mlt" then
-    process_implementation_file ppf name
-  else if Filename.check_suffix name !Config.interface_suffix then
-    process_interface_file ppf name
-  else if Filename.check_suffix name ".cmx" then
-    objfiles := name :: !objfiles
-  else if Filename.check_suffix name ".cmxa" then begin
-    cmxa_present := true;
-    objfiles := name :: !objfiles
-  end else if Filename.check_suffix name ".cmi" && !make_package then
-    objfiles := name :: !objfiles
-  else if Filename.check_suffix name ext_obj
-       || Filename.check_suffix name ext_lib then
-    ccobjs := name :: !ccobjs
-  else if Filename.check_suffix name ".c" then begin
-    Optcompile.c_file name;
-    ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj)
-              :: !ccobjs
-  end
-  else
-    raise(Arg.Bad("don't know what to do with " ^ name))
-
 let usage = "Usage: ocamlopt <options> <files>\nOptions are:"
 
-let ppf = Format.err_formatter
-
-(* Error messages to standard error formatter *)
-let anonymous filename =
-  readenv ppf (Before_compile filename);
-  process_file ppf filename;;
-
-let impl filename =
-  readenv ppf (Before_compile filename);
-  process_implementation_file ppf filename;;
-
-let intf filename =
-  readenv ppf (Before_compile filename);
-  process_interface_file ppf filename;;
-
 let show_config () =
   Config.print_config stdout;
   exit 0;
@@ -103,7 +51,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _binannot = set binary_annotations
   let _c = set compile_only
   let _cc s = c_compiler := Some s
-  let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
+  let _cclib s = defer (ProcessObjects (Misc.rev_split_words s))
   let _ccopt s = first_ccopts := s :: !first_ccopts
   let _clambda_checks () = clambda_checks := true
   let _compact = clear optimize_for_speed
@@ -114,39 +62,48 @@ module Options = Main_args.Make_optcomp_options (struct
   let _I dir = include_dirs := dir :: !include_dirs
   let _impl = impl
   let _inline spec =
-    Float_arg_helper.parse spec ~update:inline_threshold
-      ~help_text:"Syntax: -inline <n> | <round>=<n>[,...]"
+    Float_arg_helper.parse spec
+      "Syntax: -inline <n> | <round>=<n>[,...]"  inline_threshold
   let _inline_toplevel spec =
-    Int_arg_helper.parse spec ~update:inline_toplevel_threshold
-      ~help_text:"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
+      inline_toplevel_threshold
   let _inlining_report () = inlining_report := true
   let _dump_pass pass = set_dumped_pass pass true
   let _rounds n = simplify_rounds := Some n
   let _inline_max_unroll spec =
-    Int_arg_helper.parse spec ~update:inline_max_unroll
-      ~help_text:"Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
+      inline_max_unroll
   let _classic_inlining () = classic_inlining := true
   let _inline_call_cost spec =
-    Int_arg_helper.parse spec ~update:inline_call_cost
-      ~help_text:"Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
+      inline_call_cost
   let _inline_alloc_cost spec =
-    Int_arg_helper.parse spec ~update:inline_alloc_cost
-      ~help_text:"Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
+       inline_alloc_cost
   let _inline_prim_cost spec =
-    Int_arg_helper.parse spec ~update:inline_prim_cost
-      ~help_text:"Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
+       inline_prim_cost
   let _inline_branch_cost spec =
-    Int_arg_helper.parse spec ~update:inline_branch_cost
-      ~help_text:"Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
+       inline_branch_cost
   let _inline_indirect_cost spec =
-    Int_arg_helper.parse spec ~update:inline_indirect_cost
-      ~help_text:"Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
+       inline_indirect_cost
   let _inline_lifting_benefit spec =
-    Int_arg_helper.parse spec ~update:inline_lifting_benefit
-      ~help_text:"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
+      inline_lifting_benefit
   let _inline_branch_factor spec =
-    Float_arg_helper.parse spec ~update:inline_branch_factor
-      ~help_text:"Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
+    Float_arg_helper.parse spec
+      "Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
+       inline_branch_factor
   let _intf = intf
   let _intf_suffix s = Config.interface_suffix := s
   let _keep_docs = set keep_docs
@@ -156,8 +113,9 @@ module Options = Main_args.Make_optcomp_options (struct
   let _labels = clear classic
   let _linkall = set link_everything
   let _inline_max_depth spec =
-    Int_arg_helper.parse spec ~update:inline_max_depth
-      ~help_text:"Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
+       inline_max_depth
   let _alias_deps = clear transparent_modules
   let _no_alias_deps = set transparent_modules
   let _app_funct = set applicative_functors
@@ -195,6 +153,7 @@ module Options = Main_args.Make_optcomp_options (struct
     set output_c_object (); set output_complete_object ()
   let _p = set gprofile
   let _pack = set make_package
+  let _plugin p = Compplugin.load p
   let _pp s = preprocessor := Some s
   let _ppx s = first_ppx := s :: !first_ppx
   let _principal = set principal
@@ -214,6 +173,8 @@ module Options = Main_args.Make_optcomp_options (struct
   let _thread = set use_threads
   let _unbox_closures = set unbox_closures
   let _unbox_closures_factor f = unbox_closures_factor := f
+  let _unboxed_types = set unboxed_types
+  let _no_unboxed_types = clear unboxed_types
   let _unsafe = set fast
   let _unsafe_string = set unsafe_string
   let _v () = print_version_and_library "native-code compiler"
@@ -271,6 +232,12 @@ let main () =
   try
     readenv ppf Before_args;
     Arg.parse (Arch.command_line_options @ Options.list) anonymous usage;
+    Compenv.process_deferred_actions
+      (ppf,
+       Optcompile.implementation ~backend,
+       Optcompile.interface,
+       ".cmx",
+       ".cmxa");
     readenv ppf Before_link;
     if
       List.length (List.filter (fun x -> !x)
@@ -279,24 +246,22 @@ let main () =
     then
       fatal "Please specify at most one of -pack, -a, -shared, -c, -output-obj";
     if !make_archive then begin
-      if !cmxa_present then
-        fatal "Option -a cannot be used with .cmxa input files.";
       Compmisc.init_path true;
       let target = extract_output !output_name in
-      Asmlibrarian.create_archive (get_objfiles ()) target;
+      Asmlibrarian.create_archive (get_objfiles ~with_ocamlparam:false) target;
       Warnings.check_fatal ();
     end
     else if !make_package then begin
       Compmisc.init_path true;
       let target = extract_output !output_name in
       Asmpackager.package_files ppf (Compmisc.initial_env ())
-        (get_objfiles ()) target ~backend;
+        (get_objfiles ~with_ocamlparam:false) target ~backend;
       Warnings.check_fatal ();
     end
     else if !shared then begin
       Compmisc.init_path true;
       let target = extract_output !output_name in
-      Asmlink.link_shared ppf (get_objfiles ()) target;
+      Asmlink.link_shared ppf (get_objfiles ~with_ocamlparam:false) target;
       Warnings.check_fatal ();
     end
     else if not !compile_only && !objfiles <> [] then begin
@@ -316,7 +281,7 @@ let main () =
           default_output !output_name
       in
       Compmisc.init_path true;
-      Asmlink.link ppf (get_objfiles ()) target;
+      Asmlink.link ppf (get_objfiles ~with_ocamlparam:true) target;
       Warnings.check_fatal ();
     end;
   with x ->

diff --git a/driver/pparse.ml b/driver/pparse.ml
index 527291ed7bb0001c6405600cc01a6e149694e1ec..5fbaa91e42a83d4ddd9579d61952ba921237c1be 100644 (file)
--- a/driver/pparse.ml
+++ b/driver/pparse.ml
@@ -47,20 +47,26 @@ let remove_preprocessed inputfile =
     None -> ()
   | Some _ -> Misc.remove_file inputfile
 
+type 'a ast_kind =
+| Structure : Parsetree.structure ast_kind
+| Signature : Parsetree.signature ast_kind
+
+let magic_of_kind : type a . a ast_kind -> string = function
+  | Structure -> Config.ast_impl_magic_number
+  | Signature -> Config.ast_intf_magic_number
 
 (* Note: some of the functions here should go to Ast_mapper instead,
    which would encapsulate the "binary AST" protocol. *)
 
-let write_ast magic ast =
-  let fn = Filename.temp_file "camlppx" "" in
+let write_ast (type a) (kind : a ast_kind) fn (ast : a) =
   let oc = open_out_bin fn in
-  output_string oc magic;
-  output_value oc !Location.input_name;
-  output_value oc ast;
-  close_out oc;
-  fn
+  output_string oc (magic_of_kind kind);
+  output_value oc (!Location.input_name : string);
+  output_value oc (ast : a);
+  close_out oc
 
-let apply_rewriter magic fn_in ppx =
+let apply_rewriter kind fn_in ppx =
+  let magic = magic_of_kind kind in
   let fn_out = Filename.temp_file "camlppx" "" in
   let comm =
     Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out)
@@ -84,13 +90,14 @@ let apply_rewriter magic fn_in ppx =
   end;
   fn_out
 
-let read_ast magic fn =
+let read_ast (type a) (kind : a ast_kind) fn : a =
   let ic = open_in_bin fn in
   try
+    let magic = magic_of_kind kind in
     let buffer = really_input_string ic (String.length magic) in
     assert(buffer = magic); (* already checked by apply_rewriter *)
-    Location.input_name := input_value ic;
-    let ast = input_value ic in
+    Location.input_name := (input_value ic : string);
+    let ast = (input_value ic : a) in
     close_in ic;
     Misc.remove_file fn;
     ast
@@ -99,34 +106,37 @@ let read_ast magic fn =
     Misc.remove_file fn;
     raise exn
 
-let rewrite magic ast ppxs =
-  read_ast magic
-    (List.fold_left (apply_rewriter magic) (write_ast magic ast)
-       (List.rev ppxs))
+let rewrite kind ppxs ast =
+  let fn = Filename.temp_file "camlppx" "" in
+  write_ast kind fn ast;
+  let fn = List.fold_left (apply_rewriter kind) fn (List.rev ppxs) in
+  read_ast kind fn
 
 let apply_rewriters_str ?(restore = true) ~tool_name ast =
   match !Clflags.all_ppx with
   | [] -> ast
   | ppxs ->
-      let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in
-      let ast = rewrite Config.ast_impl_magic_number ast ppxs in
-      Ast_mapper.drop_ppx_context_str ~restore ast
+      ast
+      |> Ast_mapper.add_ppx_context_str ~tool_name
+      |> rewrite Structure ppxs
+      |> Ast_mapper.drop_ppx_context_str ~restore
 
 let apply_rewriters_sig ?(restore = true) ~tool_name ast =
   match !Clflags.all_ppx with
   | [] -> ast
   | ppxs ->
-      let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in
-      let ast = rewrite Config.ast_intf_magic_number ast ppxs in
-      Ast_mapper.drop_ppx_context_sig ~restore ast
-
-let apply_rewriters ?restore ~tool_name magic ast =
-  if magic = Config.ast_impl_magic_number then
-    Obj.magic (apply_rewriters_str ?restore ~tool_name (Obj.magic ast))
-  else if magic = Config.ast_intf_magic_number then
-    Obj.magic (apply_rewriters_sig ?restore ~tool_name (Obj.magic ast))
-  else
-    assert false
+      ast
+      |> Ast_mapper.add_ppx_context_sig ~tool_name
+      |> rewrite Signature ppxs
+      |> Ast_mapper.drop_ppx_context_sig ~restore
+
+let apply_rewriters ?restore ~tool_name
+    (type a) (kind : a ast_kind) (ast : a) : a =
+  match kind with
+  | Structure ->
+      apply_rewriters_str ?restore ~tool_name ast
+  | Signature ->
+      apply_rewriters_sig ?restore ~tool_name ast
 
 (* Parse a file or get a dumped syntax tree from it *)
 
@@ -148,7 +158,14 @@ let open_and_check_magic inputfile ast_magic =
   in
   (ic, is_ast_file)
 
-let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic =
+let parse (type a) (kind : a ast_kind) lexbuf : a =
+  match kind with
+  | Structure -> Parse.implementation lexbuf
+  | Signature -> Parse.interface lexbuf
+
+let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
+             (kind : a ast_kind) =
+  let ast_magic = magic_of_kind kind in
   let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
   let ast =
     try
@@ -157,8 +174,8 @@ let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic =
           (* FIXME make this a proper warning *)
           fprintf ppf "@[Warning: %s@]@."
             "option -unsafe used with a preprocessor returning a syntax tree";
-        Location.input_name := input_value ic;
-        input_value ic
+        Location.input_name := (input_value ic : string);
+        (input_value ic : a)
       end else begin
         seek_in ic 0;
         Location.input_name := inputfile;
@@ -169,12 +186,12 @@ let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic =
     with x -> close_in ic; raise x
   in
   close_in ic;
-  let ast = apply_rewriters ~restore:false ~tool_name ast_magic ast in
+  let ast = apply_rewriters ~restore:false ~tool_name kind ast in
   if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
   ast
 
-let file ppf ~tool_name inputfile parse_fun ast_magic =
-  file_aux ppf ~tool_name inputfile parse_fun ignore ast_magic
+let file ppf ~tool_name inputfile parse_fun ast_kind =
+  file_aux ppf ~tool_name inputfile parse_fun ignore ast_kind
 
 let report_error ppf = function
   | CannotRun cmd ->
@@ -191,25 +208,30 @@ let () =
       | _ -> None
     )
 
-let parse_all ~tool_name parse_fun invariant_fun magic ppf sourcefile =
+let parse_file ~tool_name invariant_fun apply_hooks kind ppf sourcefile =
   Location.input_name := sourcefile;
   let inputfile = preprocess sourcefile in
   let ast =
-    try file_aux ppf ~tool_name inputfile parse_fun invariant_fun magic
+    let parse_fun = Timings.(time (Parsing sourcefile)) (parse kind) in
+    try file_aux ppf ~tool_name inputfile parse_fun invariant_fun kind
     with exn ->
       remove_preprocessed inputfile;
       raise exn
   in
   remove_preprocessed inputfile;
+  let ast = apply_hooks { Misc.sourcefile } ast in
   ast
 
+module ImplementationHooks = Misc.MakeHooks(struct
+    type t = Parsetree.structure
+  end)
+module InterfaceHooks = Misc.MakeHooks(struct
+    type t = Parsetree.signature
+  end)
+
 let parse_implementation ppf ~tool_name sourcefile =
-  parse_all ~tool_name
-    (Timings.(time (Parsing sourcefile)) Parse.implementation)
-    Ast_invariants.structure
-    Config.ast_impl_magic_number ppf sourcefile
+  parse_file ~tool_name Ast_invariants.structure
+    ImplementationHooks.apply_hooks Structure ppf sourcefile
 let parse_interface ppf ~tool_name sourcefile =
-  parse_all ~tool_name
-    (Timings.(time (Parsing sourcefile)) Parse.interface)
-    Ast_invariants.signature
-    Config.ast_intf_magic_number ppf sourcefile
+  parse_file ~tool_name Ast_invariants.signature
+    InterfaceHooks.apply_hooks Signature ppf sourcefile

diff --git a/driver/pparse.mli b/driver/pparse.mli
index 4ccb0925e5e9201a10e015c75643750b466364bd..86d805b8a8df8ed4248764a166bb33c894d9fc39 100644 (file)
--- a/driver/pparse.mli
+++ b/driver/pparse.mli
@@ -23,10 +23,19 @@ exception Error of error
 
 val preprocess : string -> string
 val remove_preprocessed : string -> unit
-val file :
-  formatter -> tool_name:string -> string -> (Lexing.lexbuf -> 'a) -> string ->
-  'a
-val apply_rewriters: ?restore:bool -> tool_name:string -> string -> 'a -> 'a
+
+type 'a ast_kind =
+| Structure : Parsetree.structure ast_kind
+| Signature : Parsetree.signature ast_kind
+
+val read_ast : 'a ast_kind -> string -> 'a
+val write_ast : 'a ast_kind -> string -> 'a -> unit
+
+val file : formatter -> tool_name:string -> string ->
+  (Lexing.lexbuf -> 'a) -> 'a ast_kind -> 'a
+
+val apply_rewriters: ?restore:bool -> tool_name:string ->
+  'a ast_kind -> 'a -> 'a
   (** If [restore = true] (the default), cookies set by external
       rewriters will be kept for later calls. *)
 
@@ -37,7 +46,6 @@ val apply_rewriters_sig:
   ?restore:bool -> tool_name:string -> Parsetree.signature ->
   Parsetree.signature
 
-
 val report_error : formatter -> error -> unit
 
 
@@ -49,4 +57,6 @@ val parse_interface:
 (* [call_external_preprocessor sourcefile pp] *)
 val call_external_preprocessor : string -> string -> string
 val open_and_check_magic : string -> string -> in_channel * bool
-val read_ast : string -> string -> 'a
+
+module ImplementationHooks : Misc.HookSig with type t = Parsetree.structure
+module InterfaceHooks : Misc.HookSig with type t = Parsetree.signature

diff --git a/emacs/caml-types.el b/emacs/caml-types.el
index 7ecc5d4bcc4ff5a3887728784f1068e5ba16b0a2..306fa5c5c3e63367d9a7074754d0e0ca4b1316af 100644 (file)
--- a/emacs/caml-types.el
+++ b/emacs/caml-types.el
@@ -21,6 +21,12 @@
       (require 'caml-xemacs)
     (require 'caml-emacs)))
 
+(defun caml-types-feedback (info format)
+  "Displays INFO using the given FORMAT."
+  (message (format format info))
+  (with-current-buffer caml-types-buffer
+    (erase-buffer)
+    (insert info)))
 
 (defvar caml-types-build-dirs '("_build" "_obuild")
   "List of possible compilation directories created by build systems.
@@ -65,8 +71,7 @@ Their format is:
   and second nums.
 
 The current list of keywords is:
-type call ident"
-)
+type call ident")
 
 (defvar caml-types-position-re nil)
 
@@ -127,33 +132,33 @@ type call ident"
 (make-variable-buffer-local 'caml-types-annotation-date)
 
 (defvar caml-types-buffer-name "*caml-types*"
-  "Name of buffer for displaying caml types")
+  "Name of buffer for displaying caml types.")
 (defvar caml-types-buffer nil
-  "buffer for displaying caml types")
+  "Buffer for displaying caml types.")
 
 (defun caml-types-show-type (arg)
   "Show the type of expression or pattern at point.
-   The smallest expression or pattern that contains point is
-   temporarily highlighted.  Its type is highlighted in the .annot
-   file and the mark is set to the beginning of the type.
-   The type is also displayed in the mini-buffer.
-
-   Hints on using the type display:
-   . If you want the type of an identifier, put point within any
-     occurrence of this identifier.
-   . If you want the result type of a function application, put point
-     at the first space after the function name.
-   . If you want the type of a list, put point on a bracket, on a
-     semicolon, or on the :: constructor.
-   . Even if type checking fails, you can still look at the types
-     in the file, up to where the type checker failed.
+
+The smallest expression or pattern that contains point is
+temporarily highlighted.  Its type is highlighted in the .annot
+file and the mark is set to the beginning of the type.  The type
+is also displayed in the mini-buffer.
+
+Hints on using the type display:
+. If you want the type of an identifier, put point within any
+occurrence of this identifier.
+. If you want the result type of a function application, put
+point at the first space after the function name.  . If you want
+the type of a list, put point on a bracket, on a semicolon, or on
+the :: constructor.
+. Even if type checking fails, you can still look at the types
+in the file, up to where the type checker failed.
 
 Types are also displayed in the buffer *caml-types*, which is
 displayed when the command is called with Prefix argument 4.
 
 See also `caml-types-explore' for exploration by mouse dragging.
-See `caml-types-location-re' for annotation file format.
-"
+See `caml-types-location-re' for annotation file format."
   (interactive "p")
   (let* ((target-buf (current-buffer))
          (target-file (file-name-nondirectory (buffer-file-name)))
@@ -175,31 +180,26 @@ See `caml-types-location-re' for annotation file format.
               (right (caml-types-get-pos target-buf (elt node 1)))
               (type (cdr (assoc "type" (elt node 2)))))
           (move-overlay caml-types-expr-ovl left right target-buf)
-          (with-current-buffer caml-types-buffer
-            (erase-buffer)
-            (insert type)
-            (message (format "type: %s" type)))
-          ))))
+          (caml-types-feedback type "type: %s")))))
     (if (and (= arg 4)
              (not (window-live-p (get-buffer-window caml-types-buffer))))
         (display-buffer caml-types-buffer))
     (unwind-protect
         (caml-sit-for 60)
-      (delete-overlay caml-types-expr-ovl)
-      )))
+      (delete-overlay caml-types-expr-ovl))))
 
 (defun caml-types-show-call (arg)
   "Show the kind of call at point.
-   The smallest function call that contains point is
-   temporarily highlighted.  Its kind is highlighted in the .annot
-   file and the mark is set to the beginning of the kind.
-   The kind is also displayed in the mini-buffer.
+
+The smallest function call that contains point is temporarily
+highlighted.  Its kind is highlighted in the .annot file and the
+mark is set to the beginning of the kind.  The kind is also
+displayed in the mini-buffer.
 
 The kind is also displayed in the buffer *caml-types*, which is
 displayed when the command is called with Prefix argument 4.
 
-See `caml-types-location-re' for annotation file format.
-"
+See `caml-types-location-re' for annotation file format."
   (interactive "p")
   (let* ((target-buf (current-buffer))
          (target-file (file-name-nondirectory (buffer-file-name)))
@@ -221,31 +221,26 @@ See `caml-types-location-re' for annotation file format.
               (right (caml-types-get-pos target-buf (elt node 1)))
               (kind (cdr (assoc "call" (elt node 2)))))
           (move-overlay caml-types-expr-ovl left right target-buf)
-          (with-current-buffer caml-types-buffer
-            (erase-buffer)
-            (insert kind)
-            (message (format "%s call" kind)))
-          ))))
+          (caml-types-feedback kind)))))
     (if (and (= arg 4)
              (not (window-live-p (get-buffer-window caml-types-buffer))))
         (display-buffer caml-types-buffer))
     (unwind-protect
         (caml-sit-for 60)
-      (delete-overlay caml-types-expr-ovl)
-      )))
+      (delete-overlay caml-types-expr-ovl))))
 
 (defun caml-types-show-ident (arg)
   "Show the binding of identifier at point.
-   The identifier that contains point is
-   temporarily highlighted.  Its binding is highlighted in the .annot
-   file and the mark is set to the beginning of the binding.
-   The binding is also displayed in the mini-buffer.
+
+The identifier that contains point is temporarily highlighted.
+Its binding is highlighted in the .annot file and the mark is set
+to the beginning of the binding.  The binding is also displayed
+in the mini-buffer.
 
 The binding is also displayed in the buffer *caml-types*, which is
 displayed when the command is called with Prefix argument 4.
 
-See `caml-types-location-re' for annotation file format.
-"
+See `caml-types-location-re' for annotation file format."
   (interactive "p")
   (let* ((target-buf (current-buffer))
          (target-file (file-name-nondirectory (buffer-file-name)))
@@ -321,11 +316,7 @@ See `caml-types-location-re' for annotation file format.
                                    var-name l-line (- l-cnum l-bol))))))
              ((string-match external-re kind)
               (let ((fullname (match-string 1 kind)))
-                (with-current-buffer caml-types-buffer
-                  (erase-buffer)
-                  (insert fullname)
-                  (message (format "external ident: %s" fullname)))))))
-          ))))
+                (caml-types-feedback fullname "external ident: %s")))))))))
     (if (and (= arg 4)
              (not (window-live-p (get-buffer-window caml-types-buffer))))
         (display-buffer caml-types-buffer))
@@ -333,8 +324,7 @@ See `caml-types-location-re' for annotation file format.
         (caml-sit-for 60)
       (delete-overlay caml-types-expr-ovl)
       (delete-overlay caml-types-def-ovl)
-      (delete-overlay caml-types-scope-ovl)
-      )))
+      (delete-overlay caml-types-scope-ovl))))
 
 (defun caml-types-preprocess (target-path)
   (let* ((type-path (caml-types-locate-type-file target-path))
@@ -357,14 +347,13 @@ See `caml-types-location-re' for annotation file format.
         (setq caml-types-annotation-tree tree
               caml-types-annotation-date type-date)
         (kill-buffer type-buf)
-        (message "done"))
-      )))
+        (message "done")))))
 
 (defun caml-types-parent-dir (d) (file-name-directory (directory-file-name d)))
 
 (defun caml-types-locate-type-file (target-path)
-  "Given the path to an OCaml file, this function tries to locate
-and return the corresponding .annot file."
+  "Given the path to an OCaml file, try to locate and return the
+corresponding .annot file."
   (let ((sibling (concat (file-name-sans-extension target-path) ".annot")))
     (if (file-exists-p sibling)
         sibling
@@ -414,8 +403,7 @@ and return the corresponding .annot file."
   (if (re-search-forward "^[a-z\"]" () t)
       (forward-char -1)
     (goto-char (point-max)))
-  (looking-at "[a-z]")
-)
+  (looking-at "[a-z]"))
 
 ; tree of intervals
 ; each node is a vector
@@ -456,7 +444,7 @@ and return the corresponding .annot file."
                                              accu)))
             (setq stack (cons node stack))))))
     (if (null stack)
-        (error "no annotations found for this source file")
+        (error "No annotations found for this source file")
       (let* ((left-pos (elt (car (last stack)) 0))
              (right-pos (elt (car stack) 1)))
         (if (null (cdr stack))
@@ -594,15 +582,12 @@ and return the corresponding .annot file."
     (unless (verify-visited-file-modtime buf)
       (if (buffer-modified-p buf)
           (find-file-noselect name)
-        (with-current-buffer buf (revert-buffer t t)))
-      ))
+        (with-current-buffer buf (revert-buffer t t)))))
    ((and (file-readable-p name)
          (setq buf (find-file-noselect name)))
-     (with-current-buffer buf (toggle-read-only 1))
-     )
+     (with-current-buffer buf (toggle-read-only 1)))
    (t
-    (error (format "Can't read the annotation file `%s'" name)))
-    )
+    (error (format "Can't read the annotation file `%s'" name))))
   buf))
 
 (defun caml-types-mouse-ignore (event)
@@ -624,8 +609,7 @@ The function uses two overlays.
  . One overlay delimits the largest region whose all subnodes
    are well-typed.
  . Another overlay delimits the current node under the mouse (whose type
-   annotation is being displayed).
-"
+   annotation is being displayed)."
   (interactive "e")
   (set-buffer (window-buffer (caml-event-window event)))
   (let* ((target-buf (current-buffer))
@@ -638,8 +622,7 @@ The function uses two overlays.
          target-tree
          (speed 100)
          (last-time (caml-types-time))
-         (original-event event)
-         )
+         (original-event event))
     (select-window window)
     (unwind-protect
         (progn
@@ -665,15 +648,13 @@ The function uses two overlays.
                           (top (nth 1 win))
                           (bottom (- (nth 3 win) 1))
                           mouse
-                          time
-                          )
+                          time)
                      (while (and
                              (caml-sit-for 0 (/ 500 speed))
                              (setq time (caml-types-time))
                              (> (- time last-time) (/ 500 speed))
                              (setq mouse (caml-mouse-vertical-position))
-                             (or (< mouse top) (>= mouse bottom))
-                             )
+                             (or (< mouse top) (>= mouse bottom)))
                        (setq last-time time)
                        (cond
                         ((< mouse top)
@@ -685,10 +666,8 @@ The function uses two overlays.
                          (setq speed (+ 1 (- mouse bottom)))
                          (condition-case nil
                              (scroll-up 1)
-                           (error (message "End of buffer!"))))
-                        )
-                       (setq speed (* speed speed))
-                       )))
+                           (error (message "End of buffer!")))))
+                       (setq speed (* speed speed)))))
                   ;; main action, when the motion is inside the window
                   ;; or on orginal button down event
                   ((or (caml-mouse-movement-p event)
@@ -737,23 +716,15 @@ The function uses two overlays.
                          (setq limits
                                (caml-types-find-interval target-buf
                                                          target-pos node)
-                               type (cdr (assoc "type" (elt node 2))))
-                         ))
-                        )
+                               type (cdr (assoc "type" (elt node 2)))))))
                        (setq mes (format "type: %s" type))
-                       (insert type)
-                       ))
-                   (message mes)
-                   )
-                  )
+                       (insert type)))
+                   (message mes)))
                  ;; we read next event, unless it is nil, and loop back.
-                 (if event (setq event (caml-read-event)))
-                 )
-               )
+                 (if event (setq event (caml-read-event)))))
             ;; delete overlays at end of exploration
             (delete-overlay caml-types-expr-ovl)
-            (delete-overlay caml-types-typed-ovl)
-            ))
+            (delete-overlay caml-types-typed-ovl)))
       ;; When an error occurs, the mouse release event has not been read.
       ;; We could wait for mouse release to prevent execution of
       ;; a binding of mouse release, such as cut or paste.
@@ -763,8 +734,7 @@ The function uses two overlays.
       ;; Not sure it is robust to loop for mouse release after an error
       ;; occured, as is done for exploration.
       ;; So far, we just ignore next event. (Next line also be uncommenting.)
-      (if event (caml-read-event))
-      )))
+      (if event (caml-read-event)))))
 
 (defun caml-types-typed-make-overlay (target-buf pos)
   (interactive "p")
@@ -776,20 +746,17 @@ The function uses two overlays.
         (if (and (equal target-buf (current-buffer))
                  (setq left (caml-types-get-pos target-buf (elt node 0))
                        right (caml-types-get-pos target-buf (elt node 1)))
-                 (<= left pos) (> right pos)
-                 )
+                 (<= left pos) (> right pos))
             (setq start (min start left)
-                  end (max end right))
-             ))
+                  end (max end right))))
       (move-overlay caml-types-typed-ovl
                     (max (point-min) (- start 1))
                     (min (point-max) (+ end 1)) target-buf)
     (cons start end)))
 
 (defun caml-types-version ()
-  "internal version number of caml-types.el"
+  "Internal version number of caml-types.el."
   (interactive)
-  (message "4")
-)
+  (message "4"))
 
 (provide 'caml-types)

diff --git a/emacs/caml.el b/emacs/caml.el
index 2bf4246d7ef81c48c1e2749d2d21bddcbab91bfd..e91417d2a38d0e33d1ceb0518cfe14f4f99bfba9 100644 (file)
--- a/emacs/caml.el
+++ b/emacs/caml.el
@@ -803,12 +803,18 @@ variable caml-mode-indentation."
 
 ;; Newer emacs versions support line/char ranges
 ;; We will adapt OCaml to output error messages in a compatible format.
-;; In the meantime we add the new format here in addition to the old one.
+;; In the meantime we add new formats here in addition to the old one.
 (defconst caml-error-regexp-newstyle
   (concat "^[ A-\377]+ \"\\([^\"\n]+\\)\", line \\([0-9]+\\),"
           "char \\([0-9]+\\) to line \\([0-9]+\\), char \\([0-9]+\\):")
   "Regular expression matching the error messages produced by ocamlc/ocamlopt.")
 
+(defconst caml-error-regexp-new-newstyle
+  (concat "^[ A-\377]+ \"\\([^\"\n]+\\)\", line \\([0-9]+\\), "
+          "characters \\([0-9]+\\)-\\([0-9]+\\):")
+  "Regular expression matching the error messages produced by ocamlc/ocamlopt.")
+
+
 (if (boundp 'compilation-error-regexp-alist)
     (progn
       (or (assoc caml-error-regexp
@@ -820,6 +826,11 @@ variable caml-mode-indentation."
                  compilation-error-regexp-alist)
           (setq compilation-error-regexp-alist
                 (cons (list caml-error-regexp-newstyle 1 '(2 . 4) '(3 . 5))
+                      compilation-error-regexp-alist)))
+      (or (assoc caml-error-regexp-new-newstyle
+                 compilation-error-regexp-alist)
+          (setq compilation-error-regexp-alist
+                (cons (list caml-error-regexp-new-newstyle 1 2 '(3 . 4))
                       compilation-error-regexp-alist)))))
 
 ;; A regexp to extract the range info

diff --git a/lex/.depend b/lex/.depend
index 455421e7080982852a41c6d7260cd4a00447917b..4c22eeb9d0a8df74bb3507e9dc7dd6ea9107fd76 100644 (file)
--- a/lex/.depend
+++ b/lex/.depend
@@ -1,34 +1,34 @@
-common.cmi : syntax.cmi lexgen.cmi
-compact.cmi : lexgen.cmi
-cset.cmi :
-lexer.cmi : parser.cmi
-lexgen.cmi : syntax.cmi
-output.cmi : syntax.cmi lexgen.cmi compact.cmi common.cmi
-outputbis.cmi : syntax.cmi lexgen.cmi common.cmi
-parser.cmi : syntax.cmi
-syntax.cmi : cset.cmi
-table.cmi :
 common.cmo : syntax.cmi lexgen.cmi common.cmi
 common.cmx : syntax.cmx lexgen.cmx common.cmi
+common.cmi : syntax.cmi lexgen.cmi
 compact.cmo : table.cmi lexgen.cmi compact.cmi
 compact.cmx : table.cmx lexgen.cmx compact.cmi
+compact.cmi : lexgen.cmi
 cset.cmo : cset.cmi
 cset.cmx : cset.cmi
+cset.cmi :
 lexer.cmo : syntax.cmi parser.cmi lexer.cmi
 lexer.cmx : syntax.cmx parser.cmx lexer.cmi
+lexer.cmi : parser.cmi
 lexgen.cmo : table.cmi syntax.cmi cset.cmi lexgen.cmi
 lexgen.cmx : table.cmx syntax.cmx cset.cmx lexgen.cmi
+lexgen.cmi : syntax.cmi
 main.cmo : syntax.cmi parser.cmi outputbis.cmi output.cmi lexgen.cmi \
     lexer.cmi cset.cmi compact.cmi common.cmi
 main.cmx : syntax.cmx parser.cmx outputbis.cmx output.cmx lexgen.cmx \
     lexer.cmx cset.cmx compact.cmx common.cmx
 output.cmo : lexgen.cmi compact.cmi common.cmi output.cmi
 output.cmx : lexgen.cmx compact.cmx common.cmx output.cmi
+output.cmi : syntax.cmi lexgen.cmi compact.cmi common.cmi
 outputbis.cmo : lexgen.cmi common.cmi outputbis.cmi
 outputbis.cmx : lexgen.cmx common.cmx outputbis.cmi
+outputbis.cmi : syntax.cmi lexgen.cmi common.cmi
 parser.cmo : syntax.cmi cset.cmi parser.cmi
 parser.cmx : syntax.cmx cset.cmx parser.cmi
+parser.cmi : syntax.cmi
 syntax.cmo : cset.cmi syntax.cmi
 syntax.cmx : cset.cmx syntax.cmi
+syntax.cmi : cset.cmi
 table.cmo : table.cmi
 table.cmx : table.cmi
+table.cmi :

diff --git a/lex/Makefile b/lex/Makefile
index fefaaa2c1a3d017ba3a995e85384bb5bea82d732..5e3848fbca5379941428ca563da5229cea4bf722 100644 (file)
--- a/lex/Makefile
+++ b/lex/Makefile
@@ -18,9 +18,19 @@ include ../config/Makefile
 CAMLRUN ?= ../boot/ocamlrun
 CAMLYACC ?= ../boot/ocamlyacc
 
-CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot
+ROOTDIR=..
+
+ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+export OCAML_FLEXLINK:=
+else
+export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
+endif
+
+CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot \
+      -use-prims ../byterun/primitives
 CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib
-COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \
+          -safe-string -strict-sequence -strict-formats -bin-annot
 LINKFLAGS=
 YACCFLAGS=-v
 CAMLLEX=$(CAMLRUN) ../boot/ocamllex
@@ -41,7 +51,7 @@ ocamllex.opt: $(OBJS:.cmo=.cmx)
 
 clean::
        rm -f ocamllex ocamllex.opt
-       rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.o *~
+       rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.$(O) *~
 
 parser.ml parser.mli: parser.mly
        $(CAMLYACC) $(YACCFLAGS) parser.mly
@@ -72,6 +82,6 @@ beforedepend:: lexer.ml
        $(CAMLOPT) -c $(COMPFLAGS) $<
 
 depend: beforedepend
-       $(CAMLDEP) *.mli *.ml > .depend
+       $(CAMLDEP) -slash *.mli *.ml > .depend
 
 include .depend

diff --git a/lex/Makefile.nt b/lex/Makefile.nt
index 44384c77736ab68c8bcdf0c338b3ae5bbd16ec34..ed9900bb9ad68f6e5c514c060c8eb7c9788188bf 100644 (file)
--- a/lex/Makefile.nt
+++ b/lex/Makefile.nt
@@ -13,71 +13,4 @@
 #*                                                                        *
 #**************************************************************************
 
-# The lexer generator
-
-include ../config/Makefile
-CAMLRUN ?= ../boot/ocamlrun
-CAMLYACC ?= ../boot/ocamlyacc
-
-CAMLC=$(CAMLRUN) ../boot/ocamlc -I ../boot
-ifeq "$(wildcard ../flexdll/Makefile)" ""
-  FLEXLINK_ENV=
-else
-  FLEXLINK_ENV=OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe"
-endif
-CAMLOPT=$(FLEXLINK_ENV) $(CAMLRUN) ../ocamlopt -I ../stdlib
-COMPFLAGS=-warn-error A
-LINKFLAGS=
-YACCFLAGS=-v
-CAMLLEX=$(CAMLRUN) ../boot/ocamllex
-CAMLDEP=$(CAMLRUN) ../tools/ocamldep
-DEPFLAGS=
-
-OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo \
-     compact.cmo common.cmo output.cmo outputbis.cmo main.cmo
-
-all: ocamllex syntax.cmo
-allopt: ocamllex.opt
-
-ocamllex: $(OBJS)
-       $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamllex $(OBJS)
-
-ocamllex.opt: $(OBJS:.cmo=.cmx)
-       $(CAMLOPT) -o ocamllex.opt $(OBJS:.cmo=.cmx)
-
-clean::
-       rm -f ocamllex ocamllex.opt
-       rm -f *.cmo *.cmi *.cmx *.$(O)
-
-parser.ml parser.mli: parser.mly
-       $(CAMLYACC) $(YACCFLAGS) parser.mly
-
-clean::
-       rm -f parser.ml parser.mli parser.output
-
-beforedepend:: parser.ml parser.mli
-
-lexer.ml: lexer.mll
-       $(CAMLLEX) lexer.mll
-
-clean::
-       rm -f lexer.ml
-
-beforedepend:: lexer.ml
-
-.SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi .cmx
-
-.ml.cmo:
-       $(CAMLC) -c $(COMPFLAGS) $<
-
-.mli.cmi:
-       $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
-       $(CAMLOPT) -c $(COMPFLAGS) $<
-
-depend: beforedepend
-       $(CAMLDEP) *.mli *.ml > .depend
-
-include .depend
+include Makefile

diff --git a/lex/common.ml b/lex/common.ml
index 38f8291583470374dc6e23809ab198fdcc45960f..5024c829f8a3b34910f7e271d43a7c72e682ff8a 100644 (file)
--- a/lex/common.ml
+++ b/lex/common.ml
@@ -139,7 +139,7 @@ let output_env ic oc tr env =
           env in
 
       List.iter
-        (fun ((x,pos),v) ->
+        (fun ((_,pos),v) ->
           fprintf oc "%s\n" !pref ;
           copy_chunk ic oc tr pos false ;
           begin match v with

diff --git a/lex/compact.ml b/lex/compact.ml
index 5bf7e68d6d7277775c0a6d6a60de61d092ed43cd..14eda9f51fcf181cc55a1d259e3e7485178a478f 100644 (file)
--- a/lex/compact.ml
+++ b/lex/compact.ml
@@ -129,7 +129,7 @@ let do_pack state_num orig compact =
     done;
     let rec try_pack = function
       [] -> b
-    | (pos, v) :: rem ->
+    | (pos, _v) :: rem ->
         if compact.c_check.(b + pos) = -1 then
           try_pack rem
         else pack_from (b+1) in

diff --git a/lex/lexer.mll b/lex/lexer.mll
index 99dd66f500ef59c7f591d82f5faa3935c7537e77..748f5e16c40e26ce9abca2ba4d984b6f0db19848 100644 (file)
--- a/lex/lexer.mll
+++ b/lex/lexer.mll
@@ -63,8 +63,6 @@ let handle_lexical_error fn lexbuf =
   with Lexical_error (msg, "", 0, 0) ->
     raise(Lexical_error(msg, file, line, column))
 
-let get_input_name () = Sys.argv.(Array.length Sys.argv - 1)
-
 let warning lexbuf msg =
   let p = Lexing.lexeme_start_p lexbuf in
   Printf.eprintf "ocamllex warning:\nFile \"%s\", line %d, character %d: %s.\n"
@@ -190,7 +188,7 @@ rule main = parse
   | ')'  { Trparen }
   | '^'  { Tcaret }
   | '-'  { Tdash }
-  | '#'  { Tsharp }
+  | '#'  { Thash }
   | eof  { Tend }
   | _
     { raise_lexical_error lexbuf

diff --git a/lex/lexgen.ml b/lex/lexgen.ml
index 74d99c74bc8050fe38d3b8f4e1e12c3f52122a1e..4054f27cc7303273423bd020ba9de8d1a2670472 100644 (file)
--- a/lex/lexgen.ml
+++ b/lex/lexgen.ml
@@ -17,7 +17,7 @@
 (* Compiling a lexer definition *)
 
 open Syntax
-open Printf
+(*open Printf*)
 
 exception Memory_overflow
 
@@ -95,9 +95,6 @@ module TagMap =
 module IdSet =
   Set.Make (struct type t = ident let compare = id_compare end)
 
-module IdMap =
-  Map.Make (struct type t =  ident let compare = id_compare end)
-
 (*********************)
 (* Variable cleaning *)
 (*********************)
@@ -305,15 +302,6 @@ let rec encode_regexp char_vars act = function
       a previous similar tag.
 *)
 
-let incr_pos = function
-  | None   -> None
-  | Some i -> Some (i+1)
-
-let decr_pos = function
-  | None -> None
-  | Some i -> Some (i-1)
-
-
 let opt = true
 
 let mk_seq r1 r2 = match r1,r2  with
@@ -553,7 +541,7 @@ let rec nullable = function
   | Chars (_,_)|Action _ -> false
   | Seq(r1,r2) -> nullable r1 && nullable r2
   | Alt(r1,r2) -> nullable r1 || nullable r2
-  | Star r     -> true
+  | Star _     -> true
 
 let rec emptymatch = function
   | Empty | Chars (_,_) | Action _ -> Tags.empty
@@ -630,6 +618,7 @@ type 'a dfa_state =
    others : ('a * int TagMap.t) MemMap.t}
 
 
+(*
 let dtag oc t =
   fprintf oc "%s<%s>" t.id (if t.start then "s" else "e")
 
@@ -656,6 +645,7 @@ let dstate {final=(act,(_,m)) ; others=o} =
       dtag_map (fun x -> eprintf "%d" x) (fun () -> prerr_string " ,") m)
     (fun () -> prerr_endline "")
     o
+*)
 
 
 let dfa_state_empty =
@@ -858,7 +848,7 @@ let create_init_state pos =
       (fun (t,tags) st ->
         match t with
         | ToAction n ->
-            let on,otags = st.final in
+            let on,_otags = st.final in
             if n < on then
               {st with final = (n, (0,create_mem_map tags gen))}
             else
@@ -883,10 +873,12 @@ let get_map t st = match t with
 let dest = function | Copy (d,_) | Set d  -> d
 and orig = function | Copy (_,o) -> o | Set _ -> -1
 
+(*
 let pmv oc mv = fprintf oc "%d <- %d" (dest mv) (orig mv)
 let pmvs oc mvs =
   List.iter (fun mv -> fprintf oc "%a " pmv  mv) mvs ;
   output_char oc '\n' ; flush oc
+*)
 
 
 (* Topological sort << a la louche >> *)
@@ -1105,6 +1097,7 @@ let translate_state shortest_match tags chars follow st =
     reachs chars follow st.others)
   end
 
+(*
 let dtags chan tags =
   Tags.iter
     (fun t -> fprintf chan " %a" dtag t)
@@ -1126,6 +1119,7 @@ let dfollow t =
     dtransset t.(i)
   done ;
   prerr_endline "]"
+*)
 
 
 let make_tag_entry id start act a r = match a with

diff --git a/lex/main.ml b/lex/main.ml
index d49d832ec0f751b47c43dc9b8fd224b0a8449b61..fd01325d3b03ef910fb21d4bfba3f176041e0879 100644 (file)
--- a/lex/main.ml
+++ b/lex/main.ml
@@ -77,11 +77,11 @@ let main () =
     let (entries, transitions) = Lexgen.make_dfa def.entrypoints in
     if !ml_automata then begin
       Outputbis.output_lexdef
-        source_name ic oc tr
+        ic oc tr
         def.header def.refill_handler entries transitions def.trailer
     end else begin
        let tables = Compact.compact_tables transitions in
-       Output.output_lexdef source_name ic oc tr
+       Output.output_lexdef ic oc tr
          def.header def.refill_handler tables entries def.trailer
     end;
     close_in ic;

diff --git a/lex/output.ml b/lex/output.ml
index 28832039de9f107a5bef749d1e867842943d876e..17df3b3ea0843b83d2e972e89ba998a0e102df9d 100644 (file)
--- a/lex/output.ml
+++ b/lex/output.ml
@@ -72,7 +72,7 @@ let output_tables oc tbl =
 
 (* Output the entries *)
 
-let output_entry sourcefile ic oc has_refill oci e =
+let output_entry ic oc has_refill oci e =
   let init_num, init_moves = e.auto_initial_state in
   fprintf oc "%s %alexbuf =\
 \n  %a%a  __ocaml_lex_%s_rec %alexbuf %d\n"
@@ -115,7 +115,7 @@ let output_entry sourcefile ic oc has_refill oci e =
 
 exception Table_overflow
 
-let output_lexdef sourcefile ic oc oci header rh tables entry_points trailer =
+let output_lexdef ic oc oci header rh tables entry_points trailer =
   if not !Common.quiet_mode then
     Printf.printf "%d states, %d transitions, table size %d bytes\n"
       (Array.length tables.tbl_base)
@@ -141,11 +141,11 @@ let output_lexdef sourcefile ic oc oci header rh tables entry_points trailer =
     [] -> ()
   | entry1 :: entries ->
     output_string oc "let rec ";
-    output_entry sourcefile ic oc has_refill oci entry1;
+    output_entry ic oc has_refill oci entry1;
       List.iter
         (fun e ->
            output_string oc "and ";
-           output_entry sourcefile ic oc has_refill oci e)
+           output_entry ic oc has_refill oci e)
         entries;
       output_string oc ";;\n\n";
   end;

diff --git a/lex/output.mli b/lex/output.mli
index c591824bafdda3fc31d64d184547f4eef9e78f5f..13956aa93fd39c69ad1039c8406fda0e22c8aa13 100644 (file)
--- a/lex/output.mli
+++ b/lex/output.mli
@@ -16,7 +16,7 @@
 (* Output the DFA tables and its entry points *)
 
 val output_lexdef:
-      string -> in_channel -> out_channel -> Common.line_tracker ->
+      in_channel -> out_channel -> Common.line_tracker ->
       Syntax.location ->
       Syntax.location option ->
       Compact.lex_tables ->

diff --git a/lex/outputbis.ml b/lex/outputbis.ml
index 05b83118280f1bdb32f10e5a15af1cf0dff94d5d..fc8dfac886f4be62ad024096d0997379ca121624 100644 (file)
--- a/lex/outputbis.ml
+++ b/lex/outputbis.ml
@@ -37,14 +37,14 @@ let output_auto_defs oc has_refill =
 \n    if lexbuf.Lexing.lex_eof_reached then\
 \n      state lexbuf k 256\
 \n    else begin\
-\n      __ocaml_lex_refill (fun lexbuf ->
+\n      __ocaml_lex_refill (fun lexbuf ->\
 \n          lexbuf.Lexing.refill_buff lexbuf ;\
 \n          __ocaml_lex_next_char lexbuf state k)\
 \n        lexbuf\
 \n    end\
 \n  end else begin\
 \n    let i = lexbuf.Lexing.lex_curr_pos in\
-\n    let c = lexbuf.Lexing.lex_buffer.[i] in\
+\n    let c = Bytes.get lexbuf.Lexing.lex_buffer i in\
 \n    lexbuf.Lexing.lex_curr_pos <- i+1 ;\
 \n    state lexbuf k (Char.code c)\
 \n  end\
@@ -61,7 +61,7 @@ let output_auto_defs oc has_refill =
 \n    end\
 \n  end else begin\
 \n    let i = lexbuf.Lexing.lex_curr_pos in\
-\n    let c = lexbuf.Lexing.lex_buffer.[i] in\
+\n    let c = Bytes.get lexbuf.Lexing.lex_buffer i in\
 \n    lexbuf.Lexing.lex_curr_pos <- i+1 ;\
 \n    Char.code c\
 \n  end\
@@ -188,7 +188,7 @@ let output_automata oc has_refill auto =
 
 (* Output the entries *)
 
-let output_entry sourcefile ic oc has_refill tr e =
+let output_entry ic oc has_refill tr e =
   let init_num, init_moves = e.auto_initial_state in
   fprintf oc "%s %alexbuf =\n  __ocaml_lex_init_lexbuf lexbuf %d; %a"
     e.auto_name output_args e.auto_args
@@ -221,7 +221,7 @@ let output_entry sourcefile ic oc has_refill tr e =
 
 (* Main output function *)
 
-let output_lexdef sourcefile ic oc tr header rh
+let output_lexdef ic oc tr header rh
                   entry_points transitions trailer =
 
   copy_chunk ic oc tr header false;
@@ -231,10 +231,10 @@ let output_lexdef sourcefile ic oc tr header rh
     [] -> ()
   | entry1 :: entries ->
     output_string oc "let rec ";
-    output_entry sourcefile ic oc has_refill tr entry1;
+    output_entry ic oc has_refill tr entry1;
       List.iter
         (fun e -> output_string oc "and ";
-          output_entry sourcefile ic oc has_refill tr e)
+          output_entry ic oc has_refill tr e)
         entries;
       output_string oc ";;\n\n";
   end;

diff --git a/lex/outputbis.mli b/lex/outputbis.mli
index 93a84b0df1cd637a5e968eb8c992104faecd529a..44eb0e47c752daa1c0ae9e43d605db7c2fac54cb 100644 (file)
--- a/lex/outputbis.mli
+++ b/lex/outputbis.mli
@@ -14,7 +14,6 @@
 (**************************************************************************)
 
 val output_lexdef :
-  string ->
   in_channel ->
   out_channel ->
   Common.line_tracker ->

diff --git a/lex/parser.mly b/lex/parser.mly
index 995865288c2ba20497c77878cd702e83a243c3fa..0a1bb5d9667c003bf7a6ea44ed8d2363dc3e29de 100644 (file)
--- a/lex/parser.mly
+++ b/lex/parser.mly
@@ -53,13 +53,13 @@ let as_cset = function
 %token <Syntax.location> Taction
 %token Trule Tparse Tparse_shortest Tand Tequal Tend Tor Tunderscore Teof
        Tlbracket Trbracket Trefill
-%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas Tsharp
+%token Tstar Tmaybe Tplus Tlparen Trparen Tcaret Tdash Tlet Tas Thash
 
 %right Tas
 %left Tor
 %nonassoc CONCAT
 %nonassoc Tmaybe Tstar Tplus
-%left Tsharp
+%left Thash
 %nonassoc Tident Tchar Tstring Tunderscore Teof Tlbracket Tlparen
 
 %start lexer_definition
@@ -145,7 +145,7 @@ regexp:
         { Alternative(Epsilon, $1) }
   | regexp Tplus
         { Sequence(Repetition (remove_as $1), $1) }
-  | regexp Tsharp regexp
+  | regexp Thash regexp
         {
           let s1 = as_cset $1
           and s2 = as_cset $3 in

diff --git a/man/ocaml.m b/man/ocaml.m
index 54d20a990bd019a63dfa6b8850700bde282cc437..1d320022968ce81f1c51f1894f157596f6c666ad 100644 (file)
--- a/man/ocaml.m
+++ b/man/ocaml.m
@@ -38,7 +38,7 @@ that permits interactive use of the OCaml system through a
 read-eval-print loop. In this mode, the system repeatedly reads OCaml
 phrases from the input, then typechecks, compiles and evaluates
 them, then prints the inferred type and result value, if any. The
-system prints a # (sharp) prompt before reading each phrase.
+system prints a # (hash) prompt before reading each phrase.
 
 A toplevel phrase can span several lines. It is terminated by ;; (a
 double-semicolon). The syntax of toplevel phrases is as follows.
@@ -142,6 +142,11 @@ Opens the given module before starting the toplevel. If several
 options are given, they are processed in order, just as if
 the statements open! module1;; ... open! moduleN;; were input.
 .TP
+.BI \-plugin \ plugin
+Dynamically load the code of the given
+.I plugin
+(a .cmo or .cma file) in the toplevel.
+.TP
 .BI \-ppx \ command
 After parsing, pipe the abstract syntax tree through the preprocessor
 .IR command .
@@ -185,6 +190,17 @@ interactive session.
 .B \-strict\-sequence
 Force the left-hand part of each sequence to have type unit.
 .TP
+.B \-unboxed\-types
+When a type is unboxable (i.e. a record with a single argument or a
+concrete datatype with a single constructor of one argument) it will
+be unboxed unless annotated with
+.BR [@@ocaml.boxed] .
+.TP
+.B \-no-unboxed\-types
+When a type is unboxable  it will be boxed unless annotated with
+.BR [@@ocaml.unboxed] .
+This is the default.
+.TP
 .B \-unsafe
 Turn bound checking off on array and string accesses (the
 .BR v.(i) and s.[i]
@@ -206,6 +222,9 @@ Print version string and exit.
 .B \-vnum
 Print short version number and exit.
 .TP
+.B \-no\-version
+Do not print the version banner at startup.
+.TP
 .BI \-w \ warning\-list
 Enable or disable warnings according to the argument
 .IR warning-list .

diff --git a/man/ocamlc.m b/man/ocamlc.m
index b5360dcf7d8ecf4a23369a7556fbe7291b91afe9..23c98170bfe9a305691deabf04a36b3fe5051edf 100644 (file)
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -44,7 +44,7 @@ The
 .BR ocamlc (1)
 command has a command-line interface similar to the one of
 most C compilers. It accepts several types of arguments and processes them
-sequentially:
+sequentially, after all options have been processed:
 
 Arguments ending in .mli are taken to be source files for
 compilation unit interfaces. Interfaces specify the names exported by
@@ -526,6 +526,15 @@ contents of the object files a.cmo, b.cmo and c.cmo.  These
 contents can be referenced as P.A, P.B and P.C in the remainder
 of the program.
 .TP
+.BI \-plugin \ plugin
+Dynamically load the code of the given
+.I plugin
+(a .cmo, .cma or .cmxs file) in the compiler. The plugin must exist in
+the same kind of code as the compiler (ocamlc.byte must load bytecode
+plugins, while ocamlc.opt must load native code plugins), and
+extension adaptation is done automatically for .cma files (to .cmxs files
+if the compiler is compiled in native code).
+.TP
 .BI \-pp \ command
 Cause the compiler to call the given
 .I command
@@ -593,6 +602,17 @@ Compile or link multithreaded programs, in combination with the
 system "threads" library described in
 .IR The\ OCaml\ user's\ manual .
 .TP
+.B \-unboxed\-types
+When a type is unboxable (i.e. a record with a single argument or a
+concrete datatype with a single constructor of one argument) it will
+be unboxed unless annotated with
+.BR [@@ocaml.boxed] .
+.TP
+.B \-no-unboxed\-types
+When a type is unboxable  it will be boxed unless annotated with
+.BR [@@ocaml.unboxed] .
+This is the default.
+.TP
 .B \-unsafe
 Turn bound checking off for array and string accesses (the
 .BR v.(i) and s.[i]
@@ -882,6 +902,12 @@ mutually recursive types.
 59
 \ \ Assignment on non-mutable value.
 
+60
+\ \ Unused module declaration.
+
+61
+\ \ Unannotated unboxable type in primitive declaration.
+
 The letters stand for the following sets of warnings.  Any letter not
 mentioned here corresponds to the empty set.
 
@@ -935,7 +961,7 @@ mentioned here corresponds to the empty set.
 
 .IP
 The default setting is
-.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41\-42\-44\-45\-48\-50 .
+.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41\-42\-44\-45\-48\-50\-60 .
 Note that warnings
 .BR 5 \ and \ 10
 are not always triggered, depending on the internals of the type checker.
@@ -965,7 +991,7 @@ warnings or modify existing warnings.
 
 The default setting is
 .B \-warn\-error \-a+31
-(all warnings are non-fatal except 31).
+(only warning 31 is fatal).
 .TP
 .B \-warn\-help
 Show the description of all available warning numbers.

diff --git a/man/ocamlopt.m b/man/ocamlopt.m
index 1d50c1434440e8186b4ff231b92308da214d33a0..f3fb3470c4643d8371c8d9daedc7158ed7c21b90 100644 (file)
--- a/man/ocamlopt.m
+++ b/man/ocamlopt.m
@@ -44,7 +44,7 @@ command has a command-line interface very close to that
 of
 .BR ocamlc (1).
 It accepts the same types of arguments and processes them
-sequentially:
+sequentially, after all options have been processed:
 
 Arguments ending in .mli are taken to be source files for
 compilation unit interfaces. Interfaces specify the names exported by
@@ -456,6 +456,15 @@ See
 .IR "The OCaml user's manual" ,
 chapter "Native-code compilation" for more details.
 .TP
+.BI \-plugin \ plugin
+Dynamically load the code of the given
+.I plugin
+(a .cmo, .cma or .cmxs file) in the compiler. The plugin must exist in
+the same kind of code as the compiler (ocamlopt.byte must load bytecode
+plugins, while ocamlopt.opt must load native code plugins), and
+extension adaptation is done automatically for .cma files (to .cmxs files
+if the compiler is compiled in native code).
+.TP
 .BI \-pp \ command
 Cause the compiler to call the given
 .I command
@@ -539,6 +548,17 @@ Compile or link multithreaded programs, in combination with the
 system threads library described in
 .IR "The OCaml user's manual" .
 .TP
+.B \-unboxed\-types
+When a type is unboxable (i.e. a record with a single argument or a
+concrete datatype with a single constructor of one argument) it will
+be unboxed unless annotated with
+.BR [@@ocaml.boxed] .
+.TP
+.B \-no-unboxed\-types
+When a type is unboxable  it will be boxed unless annotated with
+.BR [@@ocaml.unboxed] .
+This is the default.
+.TP
 .B \-unsafe
 Turn bound checking off for array and string accesses (the
 .BR v.(i) and s.[i]
@@ -606,8 +626,8 @@ compiling your program with later versions of OCaml when they add new
 warnings or modify existing warnings.
 
 The default setting is
-.B \-warn\-error \-a
-(all warnings are non-fatal).
+.B \-warn\-error \-a+31
+(only warning 31 is fatal).
 .TP
 .B \-warn\-help
 Show the description of all available warning numbers.

diff --git a/man/ocamlyacc.m b/man/ocamlyacc.m
index 57df9e747713cefed33e5677f4b285aef1e34c0c..f522d5cc268c88ab84608babbc57d71a9633227c 100644 (file)
--- a/man/ocamlyacc.m
+++ b/man/ocamlyacc.m
@@ -79,6 +79,9 @@ instead of the default naming convention.
 .B \-q
 This option has no effect.
 .TP
+.B \--strict
+Reject grammars with conflicts.
+.TP
 .B \-v
 Generate a description of the parsing tables and a report on conflicts
 resulting from ambiguities in the grammar. The description is put in

diff --git a/middle_end/alias_analysis.ml b/middle_end/alias_analysis.ml
old mode 100644 (file)
new mode 100755 (executable)
index 2486312..0ed9ae2
--- a/middle_end/alias_analysis.ml
+++ b/middle_end/alias_analysis.ml
@@ -144,7 +144,7 @@ and fetch_symbol_field
       | fields ->
         begin match List.nth fields field with
         | None ->
-          Misc.fatal_errorf "constant field access to an inconstant %a"
+          Misc.fatal_errorf "Constant field access to an inconstant %a"
             Symbol.print sym
         | Some v ->
           fetch_variable definitions v ~the_dead_constant

diff --git a/middle_end/augment_specialised_args.ml b/middle_end/augment_specialised_args.ml
old mode 100644 (file)
new mode 100755 (executable)
index 50f6420..037918c
--- a/middle_end/augment_specialised_args.ml
+++ b/middle_end/augment_specialised_args.ml
@@ -16,7 +16,6 @@
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
 
-module A = Simple_value_approx
 module E = Inline_and_simplify_aux.Env
 module B = Inlining_cost.Benefit
 
@@ -159,7 +158,7 @@ module Processed_what_to_specialise = struct
        of closures (corresponding to another new specialised argument),
        we should re-use its "new outer var" to avoid duplication of
        projection definitions.  Likewise if the definition is just
-       [Existing_inner_free_var], in in which case we can use the
+       [Existing_inner_free_var], in which case we can use the
        corresponding existing outer free variable. *)
     let new_outer_var, t =
       let existing_outer_var =

diff --git a/middle_end/backend_intf.mli b/middle_end/backend_intf.mli
old mode 100644 (file)
new mode 100755 (executable)
index efdbbc3..c9e0092
--- a/middle_end/backend_intf.mli
+++ b/middle_end/backend_intf.mli
@@ -39,7 +39,7 @@ module type S = sig
   (** [true] iff the target architecture is big endian. *)
   val big_endian : bool
 
-  (** The maximum number of arguments that is is reasonable for a function
+  (** The maximum number of arguments that is reasonable for a function
       to have.  This should be fewer than the threshold that causes non-self
       tail call optimization to be inhibited (in particular, if it would
       entail passing arguments on the stack; see [Selectgen]). *)

diff --git a/middle_end/base_types/set_of_closures_id.mli b/middle_end/base_types/set_of_closures_id.mli
old mode 100644 (file)
new mode 100755 (executable)
index 1bcfc69..724c641
--- a/middle_end/base_types/set_of_closures_id.mli
+++ b/middle_end/base_types/set_of_closures_id.mli
@@ -17,7 +17,7 @@
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
 
 (** An identifier, unique across the whole program, that identifies a set
-    of a closures (viz. [Set_of_closures]). *)
+    of closures (viz. [Set_of_closures]). *)
 
 include Identifiable.S
 

diff --git a/middle_end/closure_conversion.ml b/middle_end/closure_conversion.ml
old mode 100644 (file)
new mode 100755 (executable)
index 7f01971..93f907f
--- a/middle_end/closure_conversion.ml
+++ b/middle_end/closure_conversion.ml
@@ -28,6 +28,7 @@ type t = {
   symbol_for_global' : (Ident.t -> Symbol.t);
   filename : string;
   mutable imported_symbols : Symbol.Set.t;
+  mutable declared_symbols : (Symbol.t * Flambda.constant_defining_value) list;
 }
 
 let add_default_argument_wrappers lam =
@@ -40,22 +41,24 @@ let add_default_argument_wrappers lam =
       Primitive.simple ~name:Closure_conversion_aux.stub_hack_prim_name
         ~arity:1 ~alloc:false
     in
-    Lprim (Pccall stub_prim, [body])
+    Lprim (Pccall stub_prim, [body], Location.none)
   in
   let defs_are_all_functions (defs : (_ * Lambda.lambda) list) =
     List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs
   in
   let f (lam : Lambda.lambda) : Lambda.lambda =
     match lam with
-    | Llet (( Strict | Alias | StrictOpt), id,
-        Lfunction {kind; params; body = fbody; attr}, body) ->
+    | Llet (( Strict | Alias | StrictOpt), _k, id,
+        Lfunction {kind; params; body = fbody; attr; loc}, body) ->
       begin match
-        Simplif.split_default_wrapper id kind params fbody attr
-          ~create_wrapper_body:stubify
+        Simplif.split_default_wrapper ~id ~kind ~params ~body:fbody
+          ~attr ~wrapper_attr:Lambda.default_function_attribute
+          ~loc ~create_wrapper_body:stubify ()
       with
-      | [fun_id, def] -> Llet (Alias, fun_id, def, body)
+      | [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body)
       | [fun_id, def; inner_fun_id, def_inner] ->
-        Llet (Alias, inner_fun_id, def_inner, Llet (Alias, fun_id, def, body))
+        Llet (Alias, Pgenval, inner_fun_id, def_inner,
+              Llet (Alias, Pgenval, fun_id, def, body))
       | _ -> assert false
       end
     | Lletrec (defs, body) as lam ->
@@ -64,9 +67,10 @@ let add_default_argument_wrappers lam =
           List.flatten
             (List.map
                (function
-                 | (id, Lambda.Lfunction {kind; params; body; attr}) ->
-                   Simplif.split_default_wrapper id kind params body attr
-                     ~create_wrapper_body:stubify
+                 | (id, Lambda.Lfunction {kind; params; body; attr; loc}) ->
+                   Simplif.split_default_wrapper ~id ~kind ~params ~body
+                     ~attr ~wrapper_attr:Lambda.default_function_attribute
+                     ~loc ~create_wrapper_body:stubify ()
                  | _ -> assert false)
                defs)
         in
@@ -109,43 +113,63 @@ let tupled_function_call_stub original_params unboxed_version
     ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline
     ~specialise:Default_specialise ~is_a_functor:false
 
-let rec eliminate_const_block (const : Lambda.structured_constant)
-      : Lambda.lambda =
-  match const with
-  | Const_block (tag, consts) ->
-    Lprim (Pmakeblock (tag, Asttypes.Immutable),
-      List.map eliminate_const_block consts)
-  | Const_base _
-  | Const_pointer _
-  | Const_immstring _
-  | Const_float_array _ -> Lconst const
-
-let default_debuginfo ?(inner_debuginfo = Debuginfo.none) env_debuginfo =
-  match env_debuginfo with
-  | None -> inner_debuginfo
-  | Some debuginfo -> debuginfo
+let register_const t (constant:Flambda.constant_defining_value) name
+      : Flambda.constant_defining_value_block_field * string =
+  let current_compilation_unit = Compilation_unit.get_current_exn () in
+  (* Create a variable to ensure uniqueness of the symbol *)
+  let var = Variable.create ~current_compilation_unit name in
+  let symbol =
+    Symbol.create current_compilation_unit
+      (Linkage_name.create (Variable.unique_name var))
+  in
+  t.declared_symbols <- (symbol, constant) :: t.declared_symbols;
+  Symbol symbol, name
 
-let rec close_const t env (const : Lambda.structured_constant)
-      : Flambda.named * string =
+let rec declare_const t (const : Lambda.structured_constant)
+      : Flambda.constant_defining_value_block_field * string =
   match const with
   | Const_base (Const_int c) -> Const (Int c), "int"
   | Const_base (Const_char c) -> Const (Char c), "char"
-  | Const_base (Const_string (s, _)) -> Allocated_const (String s), "string"
+  | Const_base (Const_string (s, _)) ->
+    let const, name =
+      if Config.safe_string then
+        Flambda.Allocated_const (Immutable_string s), "immstring"
+      else Flambda.Allocated_const (String s), "string"
+    in
+    register_const t const name
   | Const_base (Const_float c) ->
-    Allocated_const (Float (float_of_string c)), "float"
-  | Const_base (Const_int32 c) -> Allocated_const (Int32 c), "int32"
-  | Const_base (Const_int64 c) -> Allocated_const (Int64 c), "int64"
+    register_const t
+      (Allocated_const (Float (float_of_string c)))
+      "float"
+  | Const_base (Const_int32 c) ->
+    register_const t (Allocated_const (Int32 c)) "int32"
+  | Const_base (Const_int64 c) ->
+    register_const t (Allocated_const (Int64 c)) "int64"
   | Const_base (Const_nativeint c) ->
-    Allocated_const (Nativeint c), "nativeint"
+    register_const t (Allocated_const (Nativeint c)) "nativeint"
   | Const_pointer c -> Const (Const_pointer c), "pointer"
-  | Const_immstring c -> Allocated_const (Immutable_string c), "immstring"
+  | Const_immstring c ->
+    register_const t (Allocated_const (Immutable_string c)) "immstring"
   | Const_float_array c ->
-    Allocated_const (Immutable_float_array (List.map float_of_string c)),
+    register_const t
+      (Allocated_const (Immutable_float_array (List.map float_of_string c)))
       "float_array"
-  | Const_block _ ->
-    Expr (close t env (eliminate_const_block const)), "const_block"
+  | Const_block (tag, consts) ->
+    let const : Flambda.constant_defining_value =
+      Block (Tag.create_exn tag,
+             List.map (fun c -> fst (declare_const t c)) consts)
+    in
+    register_const t const "const_block"
+
+let close_const t (const : Lambda.structured_constant)
+      : Flambda.named * string =
+  match declare_const t const with
+  | Const c, name ->
+    Const c, name
+  | Symbol s, name ->
+    Symbol s, name
 
-and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
+let rec close t env (lam : Lambda.lambda) : Flambda.t =
   match lam with
   | Lvar id ->
     begin match Env.find_var_exn env id with
@@ -158,30 +182,34 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
           Ident.print id
     end
   | Lconst cst ->
-    let cst, name = close_const t env cst in
+    let cst, name = close_const t cst in
     name_expr cst ~name:("const_" ^ name)
-  | Llet ((Strict | Alias | StrictOpt), id, defining_expr, body) ->
+  | Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) ->
+    (* TODO: keep value_kind in flambda *)
     let var = Variable.create_with_same_name_as_ident id in
     let defining_expr =
       close_let_bound_expression t var env defining_expr
     in
     let body = close t (Env.add_var env id var) body in
     Flambda.create_let var defining_expr body
-  | Llet (Variable, id, defining_expr, body) ->
+  | Llet (Variable, block_kind, id, defining_expr, body) ->
     let mut_var = Mutable_variable.of_ident id in
     let var = Variable.create_with_same_name_as_ident id in
     let defining_expr =
       close_let_bound_expression t var env defining_expr
     in
     let body = close t (Env.add_mutable_var env id mut_var) body in
-    Flambda.create_let var defining_expr (Let_mutable (mut_var, var, body))
-  | Lfunction { kind; params; body; attr; } ->
+    Flambda.create_let var defining_expr
+      (Let_mutable
+         { var = mut_var;
+           initial_value = var;
+           body;
+           contents_kind = block_kind })
+  | Lfunction { kind; params; body; attr; loc; } ->
     let name =
       (* Name anonymous functions by their source location, if known. *)
-      match body with
-      | Levent (_, { lev_loc }) ->
-        Format.asprintf "anon-fn[%a]" Location.print_compact lev_loc
-      | _ -> "anon-fn"
+      if loc = Location.none then "anon-fn"
+      else Format.asprintf "anon-fn[%a]" Location.print_compact loc
     in
     let closure_bound_var = Variable.create name in
     (* CR-soon mshinwell: some of this is now very similar to the let rec case
@@ -191,7 +219,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
       let decl =
         Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind
           ~params ~body ~inline:attr.inline ~specialise:attr.specialise
-          ~is_a_functor:attr.is_a_functor
+          ~is_a_functor:attr.is_a_functor ~loc
       in
       close_functions t env (Function_decls.create [decl])
     in
@@ -216,10 +244,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
               func = func_var;
               args;
               kind = Indirect;
-              dbg =
-                default_debuginfo
-                  ~inner_debuginfo:(Debuginfo.from_location Dinfo_call ap_loc)
-                  debuginfo;
+              dbg = Debuginfo.from_location ap_loc;
               inline = ap_inlined;
               specialise = ap_specialised;
             })))
@@ -233,7 +258,8 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
       (* Identify any bindings in the [let rec] that are functions.  These
          will be named after the corresponding identifier in the [let rec]. *)
       List.map (function
-          | (let_rec_ident, Lambda.Lfunction { kind; params; body; attr; }) ->
+          | (let_rec_ident,
+             Lambda.Lfunction { kind; params; body; attr; loc }) ->
             let closure_bound_var =
               Variable.create_with_same_name_as_ident let_rec_ident
             in
@@ -241,7 +267,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
               Function_decl.create ~let_rec_ident:(Some let_rec_ident)
                 ~closure_bound_var ~kind ~params ~body
                 ~inline:attr.inline ~specialise:attr.specialise
-                ~is_a_functor:attr.is_a_functor
+                ~is_a_functor:attr.is_a_functor ~loc
             in
             Some function_declaration
           | _ -> None)
@@ -306,7 +332,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
   | Lsend (kind, meth, obj, args, loc) ->
     let meth_var = Variable.create "meth" in
     let obj_var = Variable.create "obj" in
-    let dbg = Debuginfo.from_location Dinfo_call loc in
+    let dbg = Debuginfo.from_location loc in
     Flambda.create_let meth_var (Expr (close t env meth))
       (Flambda.create_let obj_var (Expr (close t env obj))
         (Lift_code.lifting_helper (close_list t env args)
@@ -314,7 +340,9 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
           ~name:"send_arg"
           ~create_body:(fun args ->
               Send { kind; meth = meth_var; obj = obj_var; args; dbg; })))
-  | Lprim ((Pdivint | Pmodint) as prim, [arg1; arg2])
+  | Lprim ((Pdivint Safe | Pmodint Safe
+           | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }) as prim,
+           [arg1; arg2], loc)
       when not !Clflags.fast -> (* not -unsafe *)
     let arg2 = close t env arg2 in
     let arg1 = close t env arg1 in
@@ -326,16 +354,42 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
     let exn_symbol =
       t.symbol_for_global' Predef.ident_division_by_zero
     in
+    let dbg = Debuginfo.from_location loc in
+    let zero_const : Flambda.named =
+      match prim with
+      | Pdivint _ | Pmodint _ ->
+        Const (Int 0)
+      | Pdivbint { size = Pint32 } | Pmodbint { size = Pint32 } ->
+        Allocated_const (Int32 0l)
+      | Pdivbint { size = Pint64 } | Pmodbint { size = Pint64 } ->
+        Allocated_const (Int64 0L)
+      | Pdivbint { size = Pnativeint } | Pmodbint { size = Pnativeint } ->
+        Allocated_const (Nativeint 0n)
+      | _ -> assert false
+    in
+    let prim : Lambda.primitive =
+      match prim with
+      | Pdivint _ -> Pdivint Unsafe
+      | Pmodint _ -> Pmodint Unsafe
+      | Pdivbint { size } -> Pdivbint { size; is_safe = Unsafe }
+      | Pmodbint { size } -> Pmodbint { size; is_safe = Unsafe }
+      | _ -> assert false
+    in
+    let comparison : Lambda.primitive =
+      match prim with
+      | Pdivint _ | Pmodint _ -> Pintcomp Ceq
+      | Pdivbint { size } | Pmodbint { size } -> Pbintcomp (size,Ceq)
+      | _ -> assert false
+    in
     t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols;
-    Flambda.create_let zero (Const (Int 0))
+    Flambda.create_let zero zero_const
       (Flambda.create_let exn (Symbol exn_symbol)
         (Flambda.create_let denominator (Expr arg2)
           (Flambda.create_let numerator (Expr arg1)
             (Flambda.create_let is_zero
-              (Prim (Pintcomp Ceq, [zero; denominator], Debuginfo.none))
+              (Prim (comparison, [zero; denominator], dbg))
                 (If_then_else (is_zero,
-                  name_expr (Prim (Praise Raise_regular, [exn],
-                      default_debuginfo debuginfo))
+                  name_expr (Prim (Praise Raise_regular, [exn], dbg))
                     ~name:"dummy",
                   (* CR-someday pchambart: find the right event.
                      mshinwell: I briefly looked at this, and couldn't
@@ -344,13 +398,13 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
                      are suitable. I had to add a new one for a similar
                      case in the array data types work.
                      mshinwell: deferred CR *)
-                  (* Debuginfo.from_raise event *)
                   name_expr ~name:"result"
-                    (Prim (prim, [numerator; denominator],
-                      Debuginfo.none))))))))
-  | Lprim ((Pdivint | Pmodint), _) when not !Clflags.fast ->
+                    (Prim (prim, [numerator; denominator], dbg))))))))
+  | Lprim ((Pdivint Safe | Pmodint Safe
+           | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _)
+      when not !Clflags.fast ->
     Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments"
-  | Lprim (Psequor, [arg1; arg2]) ->
+  | Lprim (Psequor, [arg1; arg2], _) ->
     let arg1 = close t env arg1 in
     let arg2 = close t env arg2 in
     let const_true = Variable.create "const_true" in
@@ -358,7 +412,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
     Flambda.create_let const_true (Const (Int 1))
       (Flambda.create_let cond (Expr arg1)
         (If_then_else (cond, Var const_true, arg2)))
-  | Lprim (Psequand, [arg1; arg2]) ->
+  | Lprim (Psequand, [arg1; arg2], _) ->
     let arg1 = close t env arg1 in
     let arg2 = close t env arg2 in
     let const_false = Variable.create "const_false" in
@@ -366,11 +420,11 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
     Flambda.create_let const_false (Const (Int 0))
       (Flambda.create_let cond (Expr arg1)
         (If_then_else (cond, arg2, Var const_false)))
-  | Lprim ((Psequand | Psequor), _) ->
+  | Lprim ((Psequand | Psequor), _, _) ->
     Misc.fatal_error "Psequand / Psequor must have exactly two arguments"
-  | Lprim (Pidentity, [arg]) -> close t env arg
-  | Lprim (Pdirapply loc, [funct; arg])
-  | Lprim (Prevapply loc, [arg; funct]) ->
+  | Lprim (Pidentity, [arg], _) -> close t env arg
+  | Lprim (Pdirapply, [funct; arg], loc)
+  | Lprim (Prevapply, [arg; funct], loc) ->
     let apply : Lambda.lambda_apply =
       { ap_func = funct;
         ap_args = [arg];
@@ -383,47 +437,44 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
         ap_specialised = Default_specialise;
       }
     in
-    close t env ?debuginfo (Lambda.Lapply apply)
-  | Lprim (Praise kind, [Levent (arg, event)]) ->
+    close t env (Lambda.Lapply apply)
+  | Lprim (Praise kind, [arg], loc) ->
     let arg_var = Variable.create "raise_arg" in
+    let dbg = Debuginfo.from_location loc in
     Flambda.create_let arg_var (Expr (close t env arg))
       (name_expr
-        (Prim (Praise kind, [arg_var],
-               default_debuginfo ~inner_debuginfo:(Debuginfo.from_raise event)
-                 debuginfo))
+        (Prim (Praise kind, [arg_var], dbg))
         ~name:"raise")
-  | Lprim (Pfield _, [Lprim (Pgetglobal id, [])])
+  | Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _)
       when Ident.same id t.current_unit_id ->
     Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \
         unit is forbidden upon entry to the middle end"
-  | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, []); _]) ->
+  | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) ->
     Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \
         forbidden upon entry to the middle end"
-  | Lprim (Pgetglobal id, []) when Ident.is_predef_exn id ->
+  | Lprim (Pgetglobal id, [], _) when Ident.is_predef_exn id ->
     let symbol = t.symbol_for_global' id in
     t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
     name_expr (Symbol symbol) ~name:"predef_exn"
-  | Lprim (Pgetglobal id, []) ->
+  | Lprim (Pgetglobal id, [], _) ->
     assert (not (Ident.same id t.current_unit_id));
     let symbol = t.symbol_for_global' id in
     t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
     name_expr (Symbol symbol) ~name:"Pgetglobal"
-  | Lprim (p, args) ->
+  | Lprim (p, args, loc) ->
     (* One of the important consequences of the ANF-like representation
        here is that we obtain names corresponding to the components of
        blocks being made (with [Pmakeblock]).  This information can be used
        by the simplification pass to increase the likelihood of eliminating
        the allocation, since some field accesses can be tracked back to known
-       field values. ,*)
+       field values. *)
     let name = Printlambda.name_of_primitive p in
+    let dbg = Debuginfo.from_location loc in
     Lift_code.lifting_helper (close_list t env args)
       ~evaluation_order:`Right_to_left
       ~name:(name ^ "_arg")
       ~create_body:(fun args ->
-        let inner_debuginfo =
-          Debuginfo.from_filename Debuginfo.Dinfo_call t.filename
-        in
-        name_expr (Prim (p, args, default_debuginfo debuginfo ~inner_debuginfo))
+        name_expr (Prim (p, args, dbg))
           ~name)
   | Lswitch (arg, sw) ->
     let scrutinee = Variable.create "switch" in
@@ -437,7 +488,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
           blocks = List.map aux sw.sw_blocks;
           failaction = Misc.may_map (close t env) sw.sw_failaction;
         }))
-  | Lstringswitch (arg, sw, def) ->
+  | Lstringswitch (arg, sw, def, _) ->
     let scrutinee = Variable.create "string_switch" in
     Flambda.create_let scrutinee (Expr (close t env arg))
       (String_switch (scrutinee,
@@ -490,13 +541,7 @@ and close t ?debuginfo env (lam : Lambda.lambda) : Flambda.t =
     let new_value_var = Variable.create "new_value" in
     Flambda.create_let new_value_var (Expr (close t env new_value))
       (Assign { being_assigned; new_value = new_value_var; })
-  | Levent (lam, ev) -> begin
-      match ev.lev_kind with
-      | Lev_after _ ->
-          close t env ~debuginfo:(Debuginfo.from_call ev) lam
-      | _ ->
-          close t env lam
-    end
+  | Levent (lam, _) -> close t env lam
   | Lifused _ ->
     (* [Lifused] is used to mark that this expression should be alive only if
        an identifier is.  Every use should have been removed by
@@ -516,14 +561,8 @@ and close_functions t external_env function_declarations : Flambda.named =
   let all_free_idents = Function_decls.all_free_idents function_declarations in
   let close_one_function map decl =
     let body = Function_decl.body decl in
-    let dbg =
-      (* Move any debugging event that may exist at the start of the function
-         body onto the function declaration itself. *)
-      match body with
-      | Levent (_, ({ lev_kind = Lev_function } as ev)) ->
-        Debuginfo.from_call ev
-      | _ -> Debuginfo.none
-    in
+    let loc = Function_decl.loc decl in
+    let dbg = Debuginfo.from_location loc in
     let params = Function_decl.params decl in
     (* Create fresh variables for the elements of the closure (cf.
        the comment on [Function_decl.closure_env_without_parameters], above).
@@ -596,14 +635,14 @@ and close_list t sb l = List.map (close t sb) l
 and close_let_bound_expression t ?let_rec_ident let_bound_var env
       (lam : Lambda.lambda) : Flambda.named =
   match lam with
-  | Lfunction { kind; params; body; attr; } ->
+  | Lfunction { kind; params; body; attr; loc; } ->
     (* Ensure that [let] and [let rec]-bound functions have appropriate
        names. *)
     let closure_bound_var = Variable.rename let_bound_var in
     let decl =
       Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~params
         ~body ~inline:attr.inline ~specialise:attr.specialise
-        ~is_a_functor:attr.is_a_functor
+        ~is_a_functor:attr.is_a_functor ~loc
     in
     let set_of_closures_var =
       Variable.rename let_bound_var ~append:"_set_of_closures"
@@ -631,6 +670,7 @@ let lambda_to_flambda ~backend ~module_ident ~size ~filename lam
       symbol_for_global' = Backend.symbol_for_global';
       filename;
       imported_symbols = Symbol.Set.empty;
+      declared_symbols = [];
     }
   in
   let module_symbol = Backend.symbol_for_global' module_ident in
@@ -667,6 +707,13 @@ let lambda_to_flambda ~backend ~module_ident ~size ~filename lam
         Array.to_list fields,
         End module_symbol))
   in
+  let program_body =
+    List.fold_left
+      (fun program_body (symbol, constant) : Flambda.program_body ->
+         Let_symbol (symbol, constant, program_body))
+      module_initializer
+      t.declared_symbols
+  in
   { imported_symbols = t.imported_symbols;
-    program_body = module_initializer;
+    program_body;
   }

diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/closure_conversion_aux.ml
index d62705802959f6d58b83b55d67cb1bf410846750..becac905bab32cbdca424fbd42e3f62f666b570e 100644 (file)
--- a/middle_end/closure_conversion_aux.ml
+++ b/middle_end/closure_conversion_aux.ml
@@ -96,10 +96,11 @@ module Function_decls = struct
       inline : Lambda.inline_attribute;
       specialise : Lambda.specialise_attribute;
       is_a_functor : bool;
+      loc : Location.t;
     }
 
     let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body ~inline
-        ~specialise ~is_a_functor =
+        ~specialise ~is_a_functor ~loc =
       let let_rec_ident =
         match let_rec_ident with
         | None -> Ident.create "unnamed_function"
@@ -114,6 +115,7 @@ module Function_decls = struct
         inline;
         specialise;
         is_a_functor;
+        loc;
       }
 
     let let_rec_ident t = t.let_rec_ident
@@ -125,10 +127,11 @@ module Function_decls = struct
     let inline t = t.inline
     let specialise t = t.specialise
     let is_a_functor t = t.is_a_functor
+    let loc t = t.loc
 
     let primitive_wrapper t =
       match t.body with
-      | Lprim (Pccall { Primitive. prim_name; }, [body])
+      | Lprim (Pccall { Primitive. prim_name; }, [body], _)
         when prim_name = stub_hack_prim_name -> Some body
       | _ -> None
   end

diff --git a/middle_end/closure_conversion_aux.mli b/middle_end/closure_conversion_aux.mli
old mode 100644 (file)
new mode 100755 (executable)
index b5c84dc..b51ef52
--- a/middle_end/closure_conversion_aux.mli
+++ b/middle_end/closure_conversion_aux.mli
@@ -61,6 +61,7 @@ module Function_decls : sig
       -> inline:Lambda.inline_attribute
       -> specialise:Lambda.specialise_attribute
       -> is_a_functor:bool
+      -> loc:Location.t
       -> t
 
     val let_rec_ident : t -> Ident.t
@@ -71,9 +72,10 @@ module Function_decls : sig
     val inline : t -> Lambda.inline_attribute
     val specialise : t -> Lambda.specialise_attribute
     val is_a_functor : t -> bool
+    val loc : t -> Location.t
 
     (* [primitive_wrapper t] is [None] iff [t] is not a wrapper for a function
-       with default optionnal arguments. Otherwise it is [Some body], where
+       with default optional arguments. Otherwise it is [Some body], where
        [body] is the body of the wrapper. *)
     val primitive_wrapper : t -> Lambda.lambda option
 

diff --git a/middle_end/debuginfo.ml b/middle_end/debuginfo.ml
new file mode 100644 (file)
index 0000000..a93f425
--- /dev/null
+++ b/middle_end/debuginfo.ml
@@ -0,0 +1,96 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Lexing
+open Location
+
+type item = {
+  dinfo_file: string;
+  dinfo_line: int;
+  dinfo_char_start: int;
+  dinfo_char_end: int;
+}
+
+type t = item list
+
+let none = []
+
+let is_none = function
+  | [] -> true
+  | _ :: _ -> false
+
+let to_string dbg =
+  match dbg with
+  | [] -> ""
+  | ds ->
+    let items =
+      List.map
+        (fun d ->
+           Printf.sprintf "%s:%d,%d-%d"
+             d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end)
+        ds
+    in
+    "{" ^ String.concat ";" items ^ "}"
+
+let item_from_location loc =
+  { dinfo_file = loc.loc_start.pos_fname;
+    dinfo_line = loc.loc_start.pos_lnum;
+    dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
+    dinfo_char_end =
+      if loc.loc_end.pos_fname = loc.loc_start.pos_fname
+      then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
+      else loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
+  }
+
+let from_location loc =
+  if loc == Location.none then [] else [item_from_location loc]
+
+let to_location = function
+  | [] -> Location.none
+  | d :: _ ->
+    let loc_start =
+      { pos_fname = d.dinfo_file;
+        pos_lnum = d.dinfo_line;
+        pos_bol = 0;
+        pos_cnum = d.dinfo_char_start;
+      } in
+    let loc_end = { loc_start with pos_cnum = d.dinfo_char_end; } in
+    { loc_ghost = false; loc_start; loc_end; }
+
+let inline loc t =
+  if loc == Location.none then t
+  else (item_from_location loc) :: t
+
+let concat dbg1 dbg2 =
+  dbg1 @ dbg2
+
+let compare dbg1 dbg2 =
+  let rec loop ds1 ds2 =
+    match ds1, ds2 with
+    | [], [] -> 0
+    | _ :: _, [] -> 1
+    | [], _ :: _ -> -1
+    | d1 :: ds1, d2 :: ds2 ->
+      let c = compare d1.dinfo_file d2.dinfo_file in
+      if c <> 0 then c else
+      let c = compare d1.dinfo_line d2.dinfo_line in
+      if c <> 0 then c else
+      let c = compare d1.dinfo_char_end d2.dinfo_char_end in
+      if c <> 0 then c else
+      let c = compare d1.dinfo_char_start d2.dinfo_char_start in
+      if c <> 0 then c else
+      loop ds1 ds2
+  in
+  loop (List.rev dbg1) (List.rev dbg2)

diff --git a/middle_end/debuginfo.mli b/middle_end/debuginfo.mli
new file mode 100644 (file)
index 0000000..993928c
--- /dev/null
+++ b/middle_end/debuginfo.mli
@@ -0,0 +1,39 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type item = private {
+  dinfo_file: string;
+  dinfo_line: int;
+  dinfo_char_start: int;
+  dinfo_char_end: int
+}
+
+type t = item list
+
+val none : t
+
+val is_none : t -> bool
+
+val to_string : t -> string
+
+val from_location : Location.t -> t
+
+val to_location : t -> Location.t
+
+val concat: t -> t -> t
+
+val inline: Location.t -> t -> t
+
+val compare : t -> t -> int

diff --git a/middle_end/effect_analysis.ml b/middle_end/effect_analysis.ml
index a8c7ccb9dac28ecd7b81221e9451a33180f061d1..011dee470570894dd506e85520cfa6a7db82469b 100644 (file)
--- a/middle_end/effect_analysis.ml
+++ b/middle_end/effect_analysis.ml
@@ -27,7 +27,7 @@ let rec no_effects (flam : Flambda.t) =
   | Var _ -> true
   | Let { defining_expr; body; _ } ->
     no_effects_named defining_expr && no_effects body
-  | Let_mutable (_, _, body) -> no_effects body
+  | Let_mutable { body } -> no_effects body
   | Let_rec (defs, body) ->
     no_effects body
       && List.for_all (fun (_, def) -> no_effects_named def) defs

diff --git a/middle_end/extract_projections.ml b/middle_end/extract_projections.ml
index e8171f8a8698fdde5d9b1a5f1ac8524630c2e2c0..e00dd6debf360b4ac9ea46906c4d0ed0fb2926cf 100644 (file)
--- a/middle_end/extract_projections.ml
+++ b/middle_end/extract_projections.ml
@@ -83,7 +83,7 @@ let rec analyse_expr ~which_variables expr =
   let for_expr (expr : Flambda.expr) =
     match expr with
     | Var var
-    | Let_mutable (_, var, _) ->
+    | Let_mutable { initial_value = var } ->
       check_free_variable var
     (* CR-soon mshinwell: We don't handle [Apply] for the moment to
        avoid disabling unboxing optimizations whenever we see a recursive

diff --git a/middle_end/flambda.ml b/middle_end/flambda.ml
index bbc66382013142daf072b8bd0a9675e969f50b67..b26de62e8312a75f06b55dcb2416946640e9b9c4 100644 (file)
--- a/middle_end/flambda.ml
+++ b/middle_end/flambda.ml
@@ -59,7 +59,7 @@ type specialised_to = {
 type t =
   | Var of Variable.t
   | Let of let_expr
-  | Let_mutable of Mutable_variable.t * Variable.t * t
+  | Let_mutable of let_mutable
   | Let_rec of (Variable.t * named) list * t
   | Apply of apply
   | Send of send
@@ -95,6 +95,13 @@ and let_expr = {
   free_vars_of_body : Variable.Set.t;
 }
 
+and let_mutable = {
+  var : Mutable_variable.t;
+  initial_value : Variable.t;
+  contents_kind : Lambda.value_kind;
+  body : t;
+}
+
 and set_of_closures = {
   function_decls : function_declarations;
   free_vars : specialised_to Variable.Map.t;
@@ -182,7 +189,7 @@ let rec lam ppf (flam : t) =
   match flam with
   | Var (id) ->
       Variable.print ppf id
-  | Apply({func; args; kind; inline}) ->
+  | Apply({func; args; kind; inline; dbg}) ->
     let direct ppf () =
       match kind with
       | Indirect -> ()
@@ -195,7 +202,8 @@ let rec lam ppf (flam : t) =
       | Unroll i -> fprintf ppf "<unroll %i>" i
       | Default_inline -> ()
     in
-    fprintf ppf "@[<2>(apply%a%a@ %a%a)@]" direct () inline ()
+    fprintf ppf "@[<2>(apply%a%a<%s>@ %a%a)@]" direct () inline ()
+      (Debuginfo.to_string dbg)
       Variable.print func Variable.print_list args
   | Assign { being_assigned; new_value; } ->
     fprintf ppf "@[<2>(assign@ %a@ %a)@]"
@@ -228,8 +236,14 @@ let rec lam ppf (flam : t) =
         Variable.print id print_named arg;
       let expr = letbody body in
       fprintf ppf ")@]@ %a)@]" lam expr
-  | Let_mutable (mut_var, var, body) ->
-    fprintf ppf "@[<2>(let_mutable@ @[<2>%a@ %a@]@ %a)@]"
+  | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } ->
+    let print_kind ppf (kind : Lambda.value_kind) =
+      match kind with
+      | Pgenval -> ()
+      | _ -> Format.fprintf ppf " %s" (Printlambda.value_kind kind)
+    in
+    fprintf ppf "@[<2>(let_mutable%a@ @[<2>%a@ %a@]@ %a)@]"
+      print_kind contents_kind
       Mutable_variable.print mut_var
       Variable.print var
       lam body
@@ -330,8 +344,9 @@ and print_named ppf (named : named) =
     print_move_within_set_of_closures ppf move_within_set_of_closures
   | Set_of_closures (set_of_closures) ->
     print_set_of_closures ppf set_of_closures
-  | Prim(prim, args, _) ->
-    fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim
+  | Prim(prim, args, dbg) ->
+    fprintf ppf "@[<2>(%a<%s>%a)@]" Printlambda.primitive prim
+      (Debuginfo.to_string dbg)
       Variable.print_list args
   | Expr expr ->
     fprintf ppf "*%a" lam expr
@@ -479,7 +494,7 @@ let rec print_program_body ppf (program : program_body) =
       (Format.pp_print_list lam) fields;
     print_program_body ppf program
   | Effect (expr, program) ->
-    fprintf ppf "@[effect @[<hv 1>%a@]@@]@."
+    fprintf ppf "@[effect @[<hv 1>%a@]@]@."
       lam expr;
     print_program_body ppf program;
   | End root -> fprintf ppf "End %a" Symbol.print root
@@ -532,7 +547,7 @@ let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument
           free_variables free_vars_of_defining_expr;
           free_variables free_vars_of_body
         end
-      | Let_mutable (_mut_var, var, body) ->
+      | Let_mutable { initial_value = var; body; _ } ->
         free_variable var;
         aux body
       | Let_rec (bindings, body) ->
@@ -756,7 +771,7 @@ let iter_general ~toplevel f f_named maybe_named =
       | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable
       | Static_raise _ -> ()
       | Let _ -> assert false
-      | Let_mutable (_mut_var, _var, body) ->
+      | Let_mutable { body; _ } ->
         aux body
       | Let_rec (defs, body) ->
         List.iter (fun (_,l) -> aux_named l) defs;

diff --git a/middle_end/flambda.mli b/middle_end/flambda.mli
old mode 100644 (file)
new mode 100755 (executable)
index 6e8ede8..6826e9e
--- a/middle_end/flambda.mli
+++ b/middle_end/flambda.mli
@@ -96,7 +96,7 @@ type specialised_to = {
 type t =
   | Var of Variable.t
   | Let of let_expr
-  | Let_mutable of Mutable_variable.t * Variable.t * t
+  | Let_mutable of let_mutable
   | Let_rec of (Variable.t * named) list * t
   (** CR-someday lwhite: give Let_rec the same fields as Let. *)
   | Apply of apply
@@ -179,6 +179,13 @@ and let_expr = private {
       important optimization. *)
 }
 
+and let_mutable = {
+  var : Mutable_variable.t;
+  initial_value : Variable.t;
+  contents_kind : Lambda.value_kind;
+  body : t;
+}
+
 (** The representation of a set of function declarations (possibly mutually
     recursive).  Such a set encapsulates the declarations themselves,
     information about their defining environment, and information used
@@ -242,7 +249,7 @@ and set_of_closures = private {
       [let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid
       specialised argument because all recursive calls maintain the invariant.
 
-      This information is used for optimisation purposes, if such a binding is
+      This information is used for optimization purposes, if such a binding is
       known, it is possible to specialise the body of the function according
       to its parameter. This is usually introduced when specialising a
       recursive function, for instance.
@@ -427,7 +434,7 @@ val free_variables_named
   -> named
   -> Variable.Set.t
 
-(** Compute _all_ variables occuring inside an expression. *)
+(** Compute _all_ variables occurring inside an expression. *)
 val used_variables
    : ?ignore_uses_as_callee:unit
   -> ?ignore_uses_as_argument:unit

diff --git a/middle_end/flambda_invariants.ml b/middle_end/flambda_invariants.ml
old mode 100644 (file)
new mode 100755 (executable)
index b007a42..bde0b88
--- a/middle_end/flambda_invariants.ml
+++ b/middle_end/flambda_invariants.ml
@@ -50,6 +50,7 @@ let ignore_var_within_closure (_ : Var_within_closure.t) = ()
 let ignore_tag (_ : Tag.t) = ()
 let ignore_inline_attribute (_ : Lambda.inline_attribute) = ()
 let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = ()
+let ignore_value_kind (_ : Lambda.value_kind) = ()
 
 exception Binding_occurrence_not_from_current_compilation_unit of Variable.t
 exception Mutable_binding_occurrence_not_from_current_compilation_unit of
@@ -157,7 +158,9 @@ let variable_and_symbol_invariants (program : Flambda.program) =
     | Let { var; defining_expr; body; _ } ->
       loop_named env defining_expr;
       loop (add_binding_occurrence env var) body
-    | Let_mutable (mut_var, var, body) ->
+    | Let_mutable { var = mut_var; initial_value = var;
+                    body; contents_kind } ->
+      ignore_value_kind contents_kind;
       check_variable_is_bound env var;
       loop (add_mutable_binding_occurrence env mut_var) body
     | Let_rec (defs, body) ->
@@ -359,7 +362,7 @@ let variable_and_symbol_invariants (program : Flambda.program) =
       (* CR-someday pchambart: Ignore it to avoid the warning: get rid of that
          when the case is settled *)
       ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars);
-      (* Check that free variables variables are not bound somewhere
+      (* Check that free variables are not bound somewhere
          else in the program *)
       declare_variables (Variable.Map.keys free_vars);
       (* Check that every "specialised arg" is a parameter of one of the
@@ -463,8 +466,8 @@ let primitive_invariants flam ~no_access_to_global_module_identifiers =
             raise (Access_to_global_module_identifier prim)
           end
         | Pidentity -> raise Pidentity_should_not_occur
-        | Pdirapply _ -> raise Pdirapply_should_be_expanded
-        | Prevapply _ -> raise Prevapply_should_be_expanded
+        | Pdirapply -> raise Pdirapply_should_be_expanded
+        | Prevapply -> raise Prevapply_should_be_expanded
         | _ -> ()
         end
       | _ -> ())

diff --git a/middle_end/flambda_iterators.ml b/middle_end/flambda_iterators.ml
index 170e87eddbd33c1fdf02416a69c1fa6e4b291e40..709ccc670a78631e58d84011fe84ba610d737613 100644 (file)
--- a/middle_end/flambda_iterators.ml
+++ b/middle_end/flambda_iterators.ml
@@ -23,7 +23,7 @@ let apply_on_subexpressions f f_named (flam : Flambda.t) =
   | Let { defining_expr; body; _ } ->
     f_named defining_expr;
     f body
-  | Let_mutable (_mut_var, _var, body) ->
+  | Let_mutable { body; _ } ->
     f body
   | Let_rec (defs, body) ->
     List.iter (fun (_,l) -> f_named l) defs;
@@ -93,12 +93,12 @@ let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t =
       tree
     else
       Let_rec (new_defs, new_body)
-  | Let_mutable (mut_var, var, body) ->
-    let new_body = f body in
-    if new_body == body then
+  | Let_mutable mutable_let ->
+    let new_body = f mutable_let.body in
+    if new_body == mutable_let.body then
       tree
     else
-      Let_mutable (mut_var, var, new_body)
+      Let_mutable { mutable_let with body = new_body }
   | Switch (arg, sw) ->
     let aux = map_snd_sharing (fun _ v -> f v) in
     let new_consts = list_map_sharing aux sw.consts in
@@ -292,12 +292,12 @@ let map_general ~toplevel f f_named tree =
         | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable
         | Static_raise _ -> tree
         | Let _ -> assert false
-        | Let_mutable (mut_var, var, body) ->
-          let new_body = aux body in
-          if new_body == body then
+        | Let_mutable mutable_let ->
+          let new_body = aux mutable_let.body in
+          if new_body == mutable_let.body then
             tree
           else
-            Let_mutable (mut_var, var, new_body)
+            Let_mutable { mutable_let with body = new_body }
         | Let_rec (defs, body) ->
           let done_something = ref false in
           let defs =

diff --git a/middle_end/flambda_utils.ml b/middle_end/flambda_utils.ml
index 3f97455f5532fdbd598609558eaabd60c133bc36..14a9eafe9e62839a0ae5c57cc8e4e2fb9ef88118 100644 (file)
--- a/middle_end/flambda_utils.ml
+++ b/middle_end/flambda_utils.ml
@@ -95,9 +95,12 @@ let rec same (l1 : Flambda.t) (l2 : Flambda.t) =
     Variable.equal var1 var2 && same_named defining_expr1 defining_expr2
       && same body1 body2
   | Let _, _ | _, Let _ -> false
-  | Let_mutable (mv1, v1, b1), Let_mutable (mv2, v2, b2) ->
+  | Let_mutable {var = mv1; initial_value = v1; contents_kind = ck1; body = b1},
+    Let_mutable {var = mv2; initial_value = v2; contents_kind = ck2; body = b2}
+    ->
     Mutable_variable.equal mv1 mv2
       && Variable.equal v1 v2
+      && ck1 = ck2
       && same b1 b2
   | Let_mutable _, _ | _, Let_mutable _ -> false
   | Let_rec (bl1, a1), Let_rec (bl2, a2) ->
@@ -232,9 +235,9 @@ let toplevel_substitution sb tree =
     | Var var ->
       let var = sb var in
       Var var
-    | Let_mutable (mut_var, var, body) ->
-      let var = sb var in
-      Let_mutable (mut_var, var, body)
+    | Let_mutable mutable_let ->
+      let initial_value = sb mutable_let.initial_value in
+      Let_mutable { mutable_let with initial_value }
     | Assign { being_assigned; new_value; } ->
       let new_value = sb new_value in
       Assign { being_assigned; new_value; }
@@ -633,10 +636,12 @@ let substitute_read_symbol_field_for_variables
         Variable.Map.fold (fun to_substitute fresh expr ->
             bind to_substitute fresh expr)
           bindings expr
-    | Let_mutable (mut_var, var, body) when Variable.Map.mem var substitution ->
-      let fresh = Variable.rename var in
-      bind var fresh (Let_mutable (mut_var, fresh, body))
-    | Let_mutable (_mut_var, _var, _body) ->
+    | Let_mutable let_mutable when
+        Variable.Map.mem let_mutable.initial_value substitution ->
+      let fresh = Variable.rename let_mutable.initial_value in
+      bind let_mutable.initial_value fresh
+        (Let_mutable { let_mutable with initial_value = fresh })
+    | Let_mutable _ ->
       expr
     | Let_rec (defs, body) ->
       let free_variables_of_defs =
@@ -834,3 +839,27 @@ let projection_to_named (projection : Projection.t) : Flambda.named =
   | Move_within_set_of_closures move -> Move_within_set_of_closures move
   | Field (field_index, var) ->
     Prim (Pfield field_index, [var], Debuginfo.none)
+
+type specialised_to_same_as =
+  | Not_specialised
+  | Specialised_and_aliased_to of Variable.Set.t
+
+let parameters_specialised_to_the_same_variable
+      ~(function_decls : Flambda.function_declarations)
+      ~(specialised_args : Flambda.specialised_to Variable.Map.t) =
+  let specialised_arg_aliasing =
+    (* For each external variable involved in a specialisation, which
+       internal variable(s) it maps to via that specialisation. *)
+    Variable.Map.transpose_keys_and_data_set
+      (Variable.Map.map (fun ({ var; _ } : Flambda.specialised_to) -> var)
+        specialised_args)
+  in
+  Variable.Map.map (fun ({ params; _ } : Flambda.function_declaration) ->
+      List.map (fun param ->
+          match Variable.Map.find param specialised_args with
+          | exception Not_found -> Not_specialised
+          | { var; _ } ->
+            Specialised_and_aliased_to
+              (Variable.Map.find var specialised_arg_aliasing))
+        params)
+    function_decls.funs

diff --git a/middle_end/flambda_utils.mli b/middle_end/flambda_utils.mli
index aba0bdb12c9935bc6b54feb87e371ba59f3df279..d9030d83b603df2602f5af98a09bf91c2d776803 100644 (file)
--- a/middle_end/flambda_utils.mli
+++ b/middle_end/flambda_utils.mli
@@ -214,3 +214,18 @@ val clean_projections
   -> Flambda.specialised_to Variable.Map.t
 
 val projection_to_named : Projection.t -> Flambda.named
+
+type specialised_to_same_as =
+  | Not_specialised
+  | Specialised_and_aliased_to of Variable.Set.t
+
+(** For each parameter in a given set of function declarations and the usual
+    specialised-args mapping, determine which other parameters are specialised
+    to the same variable as that parameter.
+    The result is presented as a map from [fun_vars] to lists, corresponding
+    componentwise to the usual [params] list in the corresponding function
+    declaration. *)
+val parameters_specialised_to_the_same_variable
+   : function_decls:Flambda.function_declarations
+  -> specialised_args:Flambda.specialised_to Variable.Map.t
+  -> specialised_to_same_as list Variable.Map.t

diff --git a/middle_end/inconstant_idents.ml b/middle_end/inconstant_idents.ml
old mode 100644 (file)
new mode 100755 (executable)
index 0492180..dc0b3e2
--- a/middle_end/inconstant_idents.ml
+++ b/middle_end/inconstant_idents.ml
@@ -49,7 +49,7 @@
 
 (* CR-someday lwhite: I think this pass could be combined with
    alias_analysis and other parts of lift_constants into a single
-   type-based anaylsis which infers a "type" for each variable that is
+   type-based analysis which infers a "type" for each variable that is
    either an allocated_constant expression or "not constant".  Recursion
    would be handled with unification variables. *)
 
@@ -216,7 +216,7 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
 
   (* First loop: iterates on the tree to mark dependencies.
 
-     curr is the variables or closures to wich we add constraints like
+     curr is the variables or closures to which we add constraints like
      '... in NC => curr in NC' or 'curr in NC'
 
      It can be empty when no constraint can be added like in the toplevel
@@ -231,7 +231,7 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
          trickier than eliminating that earlier. *)
       mark_var var curr;
       mark_loop ~toplevel curr body
-    | Let_mutable (_mut_var, var, body) ->
+    | Let_mutable { initial_value = var; body } ->
       mark_var var curr;
       mark_loop ~toplevel curr body
     | Let_rec(defs, body) ->
@@ -336,7 +336,8 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
        makeblock(Mutable) can be a 'constant' if it is allocated at
        toplevel: if this expression is evaluated only once.
     *)
-    | Prim (Lambda.Pmakeblock (_tag, Asttypes.Immutable), args, _dbg) ->
+    | Prim (Lambda.Pmakeblock (_tag, Asttypes.Immutable, _value_kind), args,
+            _dbg) ->
       mark_vars args curr
 (*  (* CR-someday pchambart: If global mutables are allowed: *)
     | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _)
@@ -346,6 +347,14 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
     | Prim (Pmakearray (Pfloatarray, Immutable), args, _) ->
       mark_vars args curr
     | Prim (Pmakearray (Pfloatarray, Mutable), args, _) ->
+      (* CR-someday pchambart: Toplevel float arrays could always be
+         statically allocated using an equivalent of the
+         Initialize_symbol construction.
+         Toplevel non-float arrays could also be turned into an
+         Initialize_symbol, but only when declared as immutable since
+         preallocated symbols does not allow mutation after
+         initialisation
+      *)
       if toplevel then mark_vars args curr
       else mark_curr curr
     | Prim (Pduparray (Pfloatarray, Immutable), [arg], _) ->

diff --git a/middle_end/inline_and_simplify.ml b/middle_end/inline_and_simplify.ml
old mode 100644 (file)
new mode 100755 (executable)
index 1ce8fe2..75b47a1
--- a/middle_end/inline_and_simplify.ml
+++ b/middle_end/inline_and_simplify.ml
@@ -185,7 +185,11 @@ let approx_for_allocated_const (const : Allocated_const.t) =
   | Float_array a -> A.value_mutable_float_array ~size:(List.length a)
   | Immutable_float_array a ->
       A.value_immutable_float_array
-        (Array.map (fun x -> Some x) (Array.of_list a))
+        (Array.map A.value_float (Array.of_list a))
+
+type filtered_switch_branches =
+  | Must_be_taken of Flambda.t
+  | Can_be_taken of (int * Flambda.t) list
 
 (* Determine whether a given closure ID corresponds directly to a variable
    (bound to a closure) in the given environment.  This happens when the body
@@ -422,7 +426,7 @@ let simplify_move_within_set_of_closures env r
 
    If the function is declared outside of the alpha renamed part, there is
    no need for renaming in the [Ffunction] and [Project_var].
-   This is not usualy the case, except when the closure declaration is a
+   This is not usually the case, except when the closure declaration is a
    symbol.
 
    What ensures that this information is available at [Project_var]
@@ -554,7 +558,7 @@ let rec simplify_project_var env r ~(project_var : Flambda.project_var)
    will be introduced in the current scope for [y_1] each time.
 
 
-   If the function where a recursive one comming from another compilation
+   If the function where a recursive one coming from another compilation
    unit, the code already went through [Flambdasym] that could have
    replaced the function variable by the symbol identifying the function
    (this occur if the function contains only constants in its closure).
@@ -593,7 +597,7 @@ and simplify_set_of_closures original_env r
       E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var)
         ~inline_inside:
           (Inlining_decision.should_inline_inside_declaration function_decl)
-        ~debuginfo:function_decl.dbg
+        ~dbg:function_decl.dbg
         ~f:(fun body_env -> simplify body_env r function_decl.body)
     in
     let inline : Lambda.inline_attribute =
@@ -668,6 +672,7 @@ and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t =
     Flambda. func = lhs_of_application; args; kind = _; dbg;
     inline = inline_requested; specialise = specialise_requested;
   } = apply in
+  let dbg = E.add_inlined_debuginfo env ~dbg in
   simplify_free_variable env lhs_of_application
     ~f:(fun env lhs_of_application lhs_of_application_approx ->
       simplify_free_variables env args ~f:(fun env args args_approxs ->
@@ -978,6 +983,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
   | Move_within_set_of_closures move_within_set_of_closures ->
     simplify_move_within_set_of_closures env r ~move_within_set_of_closures
   | Prim (prim, args, dbg) ->
+    let dbg = E.add_inlined_debuginfo env ~dbg in
     simplify_free_variables_named env args ~f:(fun env args args_approxs ->
       let tree = Flambda.Prim (prim, args, dbg) in
       begin match prim, args, args_approxs with
@@ -1006,16 +1012,43 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
               | None | Some (_, Some _ ) ->
                 (* This [Pfield] is either not projecting from a symbol at all,
                    or it is the projection of a projection from a symbol. *)
-                let module Backend = (val (E.backend env) : Backend_intf.S) in
-                let approx' = Backend.really_import_approx approx in
+                let approx' = E.really_import_approx env approx in
                 tree, approx'
             in
             simplify_named_using_approx_and_env env r tree approx
           end
         end
       | Pfield _, _, _ -> Misc.fatal_error "Pfield arity error"
-      | (Psetfield _ | Parraysetu _ | Parraysets _),
-          _block::_, block_approx::_ ->
+      | (Parraysetu kind | Parraysets kind),
+        [_block; _field; _value],
+        [block_approx; _field_approx; value_approx] ->
+        if A.is_definitely_immutable block_approx then begin
+          Location.prerr_warning (Debuginfo.to_location dbg)
+            Warnings.Assignment_to_non_mutable_value
+        end;
+        let kind = match A.descr block_approx, A.descr value_approx with
+          | (Value_float_array _, _)
+          | (_, Value_float _) ->
+            begin match kind with
+            | Pfloatarray | Pgenarray -> ()
+            | Paddrarray | Pintarray ->
+              (* CR pchambart: Do a proper warning here *)
+              Misc.fatal_errorf "Assignment of a float to a specialised \
+                                 non-float array: %a"
+                Flambda.print_named tree
+            end;
+            Lambda.Pfloatarray
+            (* CR pchambart: This should be accounted by the benefit *)
+          | _ ->
+            kind
+        in
+        let prim : Lambda.primitive = match prim with
+          | Parraysetu _ -> Parraysetu kind
+          | Parraysets _ -> Parraysets kind
+          | _ -> assert false
+        in
+        Prim (prim, args, dbg), ret r (A.value_unknown Other)
+      | Psetfield _, _block::_, block_approx::_ ->
         if A.is_definitely_immutable block_approx then begin
           Location.prerr_warning (Debuginfo.to_location dbg)
             Warnings.Assignment_to_non_mutable_value
@@ -1081,7 +1114,7 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
       ~for_defining_expr
       ~for_last_body
       ~filter_defining_expr
-  | Let_mutable (mut_var, var, body) ->
+  | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } ->
     (* CR-someday mshinwell: add the dead let elimination, as above. *)
     simplify_free_variable env var ~f:(fun env var _var_approx ->
       let mut_var, sb =
@@ -1091,7 +1124,12 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
       let body, r =
         simplify (E.add_mutable env mut_var (A.value_unknown Other)) r body
       in
-      Flambda.Let_mutable (mut_var, var, body), r)
+      Flambda.Let_mutable
+        { var = mut_var;
+          initial_value = var;
+          body;
+          contents_kind },
+      r)
   | Let_rec (defs, body) ->
     let defs, sb = Freshening.add_variables (E.freshening env) defs in
     let env = E.set_freshening env sb in
@@ -1144,6 +1182,7 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
             simplify env r handler
           | _ ->
             let vars, sb = Freshening.add_variables' (E.freshening env) vars in
+            let approx = R.approx r in
             let env =
               List.fold_left (fun env id ->
                   E.add env id (A.value_unknown Other))
@@ -1153,7 +1192,7 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
             let handler, r = simplify env r handler in
             let r = R.exit_scope_catch r i in
             Static_catch (i, vars, body, handler),
-              ret r (A.value_unknown Other)
+              R.meet_approx r env approx
         end
     end
   | Try_with (body, id, handler) ->
@@ -1181,15 +1220,15 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
         let ifso, r = simplify env r ifso in
         let ifso_approx = R.approx r in
         let ifnot, r = simplify env r ifnot in
-        let ifnot_approx = R.approx r in
         If_then_else (arg, ifso, ifnot),
-          ret r (A.meet ifso_approx ifnot_approx)
+          R.meet_approx r env ifso_approx
       end)
   | While (cond, body) ->
     let cond, r = simplify env r cond in
     let body, r = simplify env r body in
     While (cond, body), ret r (A.value_unknown Other)
   | Send { kind; meth; obj; args; dbg; } ->
+    let dbg = E.add_inlined_debuginfo env ~dbg in
     simplify_free_variable env meth ~f:(fun env meth _meth_approx ->
       simplify_free_variable env obj ~f:(fun env obj _obj_approx ->
         simplify_free_variables env args ~f:(fun _env args _args_approx ->
@@ -1222,7 +1261,34 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
        [Switch].  (This should also make the [Let] that binds [arg] redundant,
        meaning that it too can be eliminated.) *)
     simplify_free_variable env arg ~f:(fun env arg arg_approx ->
-      let get_failaction () : Flambda.t =
+      let rec filter_branches filter branches compatible_branches =
+        match branches with
+        | [] -> Can_be_taken compatible_branches
+        | (c, lam) as branch :: branches ->
+          match filter arg_approx c with
+          | A.Cannot_be_taken ->
+            filter_branches filter branches compatible_branches
+          | A.Can_be_taken ->
+            filter_branches filter branches (branch :: compatible_branches)
+          | A.Must_be_taken ->
+            Must_be_taken lam
+      in
+      let filtered_consts =
+        filter_branches A.potentially_taken_const_switch_branch sw.consts []
+      in
+      let filtered_blocks =
+        filter_branches A.potentially_taken_block_switch_branch sw.blocks []
+      in
+      begin match filtered_consts, filtered_blocks with
+      | Must_be_taken _, Must_be_taken _ ->
+        assert false
+      | Must_be_taken branch, _
+      | _, Must_be_taken branch ->
+        let lam, r = simplify env r branch in
+        lam, R.map_benefit r B.remove_branch
+      | Can_be_taken consts, Can_be_taken blocks ->
+        match consts, blocks, sw.failaction with
+        | [], [], None ->
         (* If the switch is applied to a statically-known value that does not
            match any case:
            * if there is a default action take that case;
@@ -1235,65 +1301,72 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
                 match v with   <-- This match is unreachable
                 | Float f -> ...]
          *)
-        match sw.failaction with
-        | None -> Proved_unreachable
-        | Some f -> f
-      in
-      begin match arg_approx.descr with
-      | Value_int i
-      | Value_constptr i ->
-        let lam =
-          try List.assoc i sw.consts
-          with Not_found -> get_failaction ()
-        in
-        let lam, r = simplify env r lam in
-        lam, R.map_benefit r B.remove_branch
-      | Value_block (tag, _) ->
-        let tag = Tag.to_int tag in
-        let lam =
-          try List.assoc tag sw.blocks
-          with Not_found -> get_failaction ()
-        in
-        let lam, r = simplify env r lam in
-        lam, R.map_benefit r B.remove_branch
-      | _ ->
+          Proved_unreachable, ret r A.value_bottom
+        | [_, branch], [], None
+        | [], [_, branch], None
+        | [], [], Some branch ->
+          let lam, r = simplify env r branch in
+          lam, R.map_benefit r B.remove_branch
+        | _ ->
+          let env = E.inside_branch env in
+          let f (i, v) (acc, r) =
+            let approx = R.approx r in
+            let lam, r = simplify env r v in
+            (i, lam)::acc,
+            R.meet_approx r env approx
+          in
+          let r = R.set_approx r A.value_bottom in
+          let consts, r = List.fold_right f consts ([], r) in
+          let blocks, r = List.fold_right f blocks ([], r) in
+          let failaction, r =
+            match sw.failaction with
+            | None -> None, r
+            | Some l ->
+              let approx = R.approx r in
+              let l, r = simplify env r l in
+              Some l,
+              R.meet_approx r env approx
+          in
+          let sw = { sw with failaction; consts; blocks; } in
+          Switch (arg, sw), r
+      end)
+  | String_switch (arg, sw, def) ->
+    simplify_free_variable env arg ~f:(fun env arg arg_approx ->
+      match A.check_approx_for_string arg_approx with
+      | None ->
         let env = E.inside_branch env in
-        let f (i, v) (acc, r) =
-          let approx = R.approx r in
-          let lam, r = simplify env r v in
-          ((i, lam)::acc, R.set_approx r (A.meet (R.approx r) approx))
+        let sw, r =
+          List.fold_right (fun (str, lam) (sw, r) ->
+              let approx = R.approx r in
+              let lam, r = simplify env r lam in
+              (str, lam)::sw,
+                R.meet_approx r env approx)
+            sw
+            ([], r)
         in
-        let r = R.set_approx r A.value_bottom in
-        let consts, r = List.fold_right f sw.consts ([], r) in
-        let blocks, r = List.fold_right f sw.blocks ([], r) in
-        let failaction, r =
-          match sw.failaction with
-          | None -> None, r
-          | Some l ->
+        let def, r =
+          match def with
+          | None -> def, r
+          | Some def ->
             let approx = R.approx r in
-            let l, r = simplify env r l in
-            Some l, R.set_approx r (A.meet (R.approx r) approx)
+            let def, r = simplify env r def in
+            Some def,
+              R.meet_approx r env approx
         in
-        let sw = { sw with failaction; consts; blocks; } in
-        Switch (arg, sw), r
-      end)
-  | String_switch (arg, sw, def) ->
-    simplify_free_variable env arg ~f:(fun env arg _arg_approx ->
-      let sw, r =
-        List.fold_right (fun (str, lam) (sw, r) ->
-            let lam, r = simplify env r lam in
-            (str, lam)::sw, r)
-          sw
-          ([], r)
-      in
-      let def, r =
-        match def with
-        | None -> def, r
-        | Some def ->
-          let def, r = simplify env r def in
-          Some def, r
-      in
-      String_switch (arg, sw, def), ret r (A.value_unknown Other))
+        String_switch (arg, sw, def), ret r (A.value_unknown Other)
+      | Some arg_string ->
+        let branch =
+          match List.find (fun (str, _) -> str = arg_string) sw with
+          | (_, branch) -> branch
+          | exception Not_found ->
+            match def with
+            | None ->
+              Flambda.Proved_unreachable
+            | Some def ->
+              def
+        in
+        let branch, r = simplify env r branch in
+        branch, R.map_benefit r B.remove_branch)
   | Proved_unreachable -> tree, ret r A.value_bottom
 
 and simplify_list env r l =
@@ -1339,7 +1412,7 @@ and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures)
     E.enter_closure closure_env
       ~closure_id:(Closure_id.wrap fun_var)
       ~inline_inside:false
-      ~debuginfo:function_decl.dbg
+      ~dbg:function_decl.dbg
       ~f:(fun body_env ->
         simplify body_env (R.create ()) function_decl.body)
   in
@@ -1582,7 +1655,7 @@ let run ~never_inline ~backend ~prefixname ~round program =
   let result = Flambda_utils.introduce_needed_import_symbols result in
   if not (Static_exception.Set.is_empty (R.used_static_exceptions r))
   then begin
-    Misc.fatal_error (Format.asprintf "remaining static exceptions: %a@.%a@."
+    Misc.fatal_error (Format.asprintf "Remaining static exceptions: %a@.%a@."
       Static_exception.Set.print (R.used_static_exceptions r)
       Flambda.print_program result)
   end;

diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/inline_and_simplify_aux.ml
index 4f49a2fcef9eb97a63703d2e76c703ef9b84d479..f853d451be3cc3cf8d68494ad6b12d86604bce7c 100644 (file)
--- a/middle_end/inline_and_simplify_aux.ml
+++ b/middle_end/inline_and_simplify_aux.ml
@@ -41,6 +41,7 @@ module Env = struct
     actively_unrolling : int Set_of_closures_origin.Map.t;
     closure_depth : int;
     inlining_stats_closure_stack : Inlining_stats.Closure_stack.t;
+    inlined_debuginfo : Debuginfo.t;
   }
 
   let create ~never_inline ~backend ~round =
@@ -63,6 +64,7 @@ module Env = struct
       closure_depth = 0;
       inlining_stats_closure_stack =
         Inlining_stats.Closure_stack.create ();
+      inlined_debuginfo = Debuginfo.none;
     }
 
   let backend t = t.backend
@@ -73,6 +75,7 @@ module Env = struct
       approx = Variable.Map.empty;
       projections = Projection.Map.empty;
       freshening = Freshening.empty_preserving_activation_state env.freshening;
+      inlined_debuginfo = Debuginfo.none;
     }
 
   let inlining_level_up env =
@@ -112,9 +115,9 @@ module Env = struct
         Mutable_variable.Map.add mut_var approx t.approx_mutable;
     }
 
-  let really_import_approx t approx =
+  let really_import_approx t =
     let module Backend = (val (t.backend) : Backend_intf.S) in
-    Backend.really_import_approx approx
+    Backend.really_import_approx
 
   let really_import_approx_with_scope t (scope, approx) =
     scope, really_import_approx t approx
@@ -348,22 +351,22 @@ module Env = struct
   let freshening t = t.freshening
   let never_inline t = t.never_inline || t.never_inline_outside_closures
 
-  let note_entering_closure t ~closure_id ~debuginfo =
+  let note_entering_closure t ~closure_id ~dbg =
     if t.never_inline then t
     else
       { t with
         inlining_stats_closure_stack =
           Inlining_stats.Closure_stack.note_entering_closure
-            t.inlining_stats_closure_stack ~closure_id ~debuginfo;
+            t.inlining_stats_closure_stack ~closure_id ~dbg;
       }
 
-  let note_entering_call t ~closure_id ~debuginfo =
+  let note_entering_call t ~closure_id ~dbg =
     if t.never_inline then t
     else
       { t with
         inlining_stats_closure_stack =
           Inlining_stats.Closure_stack.note_entering_call
-            t.inlining_stats_closure_stack ~closure_id ~debuginfo;
+            t.inlining_stats_closure_stack ~closure_id ~dbg;
       }
 
   let note_entering_inlined t =
@@ -384,17 +387,23 @@ module Env = struct
             t.inlining_stats_closure_stack ~closure_ids;
       }
 
-  let enter_closure t ~closure_id ~inline_inside ~debuginfo ~f =
+  let enter_closure t ~closure_id ~inline_inside ~dbg ~f =
     let t =
       if inline_inside && not t.never_inline_inside_closures then t
       else set_never_inline t
     in
     let t = unset_never_inline_outside_closures t in
-    f (note_entering_closure t ~closure_id ~debuginfo)
+    f (note_entering_closure t ~closure_id ~dbg)
 
   let record_decision t decision =
     Inlining_stats.record_decision decision
       ~closure_stack:t.inlining_stats_closure_stack
+
+  let set_inline_debuginfo t ~dbg =
+    { t with inlined_debuginfo = dbg }
+
+  let add_inlined_debuginfo t ~dbg =
+    Debuginfo.concat t.inlined_debuginfo dbg
 end
 
 let initial_inlining_threshold ~round : Inlining_cost.Threshold.t =
@@ -423,8 +432,6 @@ let initial_inlining_toplevel_threshold ~round : Inlining_cost.Threshold.t =
     (unscaled * Inlining_cost.scale_inline_threshold_by)
 
 module Result = struct
-  module Int = Numbers.Int
-
   type t =
     { approx : Simple_value_approx.t;
       used_static_exceptions : Static_exception.Set.t;
@@ -444,6 +451,13 @@ module Result = struct
   let approx t = t.approx
   let set_approx t approx = { t with approx }
 
+  let meet_approx t env approx =
+    let really_import_approx = Env.really_import_approx env in
+    let meet =
+      Simple_value_approx.meet ~really_import_approx t.approx approx
+    in
+    set_approx t meet
+
   let use_static_exception t i =
     { t with
       used_static_exceptions =

diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/inline_and_simplify_aux.mli
old mode 100644 (file)
new mode 100755 (executable)
index a3a581d..a1b71c1
--- a/middle_end/inline_and_simplify_aux.mli
+++ b/middle_end/inline_and_simplify_aux.mli
@@ -39,6 +39,11 @@ module Env : sig
       compiler backend being used for compilation. *)
   val backend : t -> (module Backend_intf.S)
 
+  (** Obtain the really_import_approx function from the backend module. *)
+  val really_import_approx
+     : t
+    -> (Simple_value_approx.t -> Simple_value_approx.t)
+
   (** Which simplification round we are currently in. *)
   val round : t -> int
 
@@ -172,7 +177,7 @@ module Env : sig
   val inlining_level : t -> int
 
   (** Mark that this environment is used to rewrite code for inlining. This is
-      used by the inlining heuristics to decide wether to continue.
+      used by the inlining heuristics to decide whether to continue.
       Unconditionally inlined does not take this into account. *)
   val inlining_level_up : t -> t
 
@@ -208,7 +213,7 @@ module Env : sig
   val note_entering_closure
      : t
     -> closure_id:Closure_id.t
-    -> debuginfo:Debuginfo.t
+    -> dbg:Debuginfo.t
     -> t
 
    (** If collecting inlining statistics, record that the inliner is about to
@@ -218,7 +223,7 @@ module Env : sig
   val note_entering_call
      : t
     -> closure_id:Closure_id.t
-    -> debuginfo:Debuginfo.t
+    -> dbg:Debuginfo.t
     -> t
 
    (** If collecting inlining statistics, record that the inliner is about to
@@ -239,7 +244,7 @@ module Env : sig
      : t
     -> closure_id:Closure_id.t
     -> inline_inside:bool
-    -> debuginfo:Debuginfo.t
+    -> dbg:Debuginfo.t
     -> f:(t -> 'a)
     -> 'a
 
@@ -253,6 +258,14 @@ module Env : sig
 
   (** Print a human-readable version of the given environment. *)
   val print : Format.formatter -> t -> unit
+
+  (** The environment stores the call-site being inlined to produce
+      precise location information. This function sets the current
+      call-site being inlined.  *)
+  val set_inline_debuginfo : t -> dbg:Debuginfo.t -> t
+
+  (** Appends the locations of inlined call-sites to the [~dbg] argument *)
+  val add_inlined_debuginfo : t -> dbg:Debuginfo.t -> Debuginfo.t
 end
 
 module Result : sig
@@ -272,6 +285,12 @@ module Result : sig
       simplification algorithm. *)
   val set_approx : t -> Simple_value_approx.t -> t
 
+  (** Set the approximation of the subexpression to the meet of the
+      current return aprroximation and the provided one. Typically
+      used just before returning from a branch case of the
+      simplification algorithm. *)
+  val meet_approx : t -> Env.t -> Simple_value_approx.t -> t
+
   (** All static exceptions for which [use_staticfail] has been called on
       the given result structure. *)
   val used_static_exceptions : t -> Static_exception.Set.t

diff --git a/middle_end/inlining_cost.ml b/middle_end/inlining_cost.ml
index 27f0f58e1054eb1e5be2041336c304b244611216..9c049effbcb9b1de2b39427ec40458c68c89eca2 100644 (file)
--- a/middle_end/inlining_cost.ml
+++ b/middle_end/inlining_cost.ml
@@ -39,7 +39,9 @@ let prim_size (prim : Lambda.primitive) args =
   | Pccall p -> (if p.Primitive.prim_alloc then 10 else 4) + List.length args
   | Praise _ -> 4
   | Pstringlength -> 5
-  | Pstringrefs | Pstringsets -> 6
+  | Pbyteslength -> 5
+  | Pstringrefs -> 6
+  | Pbytesrefs | Pbytessets -> 6
   | Pmakearray _ -> 5 + List.length args
   | Parraylength Pgenarray -> 6
   | Parraylength _ -> 2
@@ -85,7 +87,7 @@ let lambda_smaller' lam ~than:threshold =
     | Let { defining_expr; body; _ } ->
       lambda_named_size defining_expr;
       lambda_size body
-    | Let_mutable (_, _, body) -> lambda_size body
+    | Let_mutable { body } -> lambda_size body
     | Let_rec (bindings, body) ->
       List.iter (fun (_, lam) -> lambda_named_size lam) bindings;
       lambda_size body

diff --git a/middle_end/inlining_decision.ml b/middle_end/inlining_decision.ml
old mode 100644 (file)
new mode 100755 (executable)
index f9cf885..730419b
--- a/middle_end/inlining_decision.ml
+++ b/middle_end/inlining_decision.ml
@@ -37,7 +37,7 @@ let inline env r ~lhs_of_application
     ~(function_decls : Flambda.function_declarations)
     ~closure_id_being_applied ~(function_decl : Flambda.function_declaration)
     ~value_set_of_closures ~only_use_of_function ~original ~recursive
-    ~(args : Variable.t list) ~size_from_approximation ~simplify
+    ~(args : Variable.t list) ~size_from_approximation ~dbg ~simplify
     ~(inline_requested : Lambda.inline_attribute)
     ~(specialise_requested : Lambda.specialise_attribute)
     ~self_call ~fun_cost ~inlining_threshold =
@@ -119,7 +119,7 @@ let inline env r ~lhs_of_application
 
           We may need to think a bit about that. I can't see a lot of
           meaningful examples right now, but there are some cases where some
-          optimisation can happen even if we don't know anything about the
+          optimization can happen even if we don't know anything about the
           shape of the arguments.
 
           For instance
@@ -192,7 +192,7 @@ let inline env r ~lhs_of_application
       Inlining_transforms.inline_by_copying_function_body ~env
         ~r:(R.reset_benefit r) ~function_decls ~lhs_of_application
         ~closure_id_being_applied ~specialise_requested ~inline_requested
-        ~function_decl ~args ~simplify
+        ~function_decl ~args ~dbg ~simplify
     in
     let num_direct_applications_seen =
       (R.num_direct_applications r_inlined) - (R.num_direct_applications r)
@@ -251,7 +251,7 @@ let inline env r ~lhs_of_application
       else if num_direct_applications_seen < 1 then begin
       (* Inlining the body of the function did not appear sufficiently
          beneficial; however, it may become so if we inline within the body
-         first.  We try that next, unless it is known that there are were
+         first.  We try that next, unless it is known that there were
          no direct applications in the simplified body computed above, meaning
          no opportunities for inlining. *)
         Original (S.Not_inlined.Without_subfunctions wsb)
@@ -362,12 +362,12 @@ let specialise env r ~lhs_of_application
        - has useful approximations for some invariant parameters. *)
     if !Clflags.classic_inlining then
       Don't_try_it S.Not_specialised.Classic_mode
+    else if self_call then
+      Don't_try_it S.Not_specialised.Self_call
     else if always_specialise && not (Lazy.force has_no_useful_approxes) then
       Try_it
     else if never_specialise then
       Don't_try_it S.Not_specialised.Annotation
-    else if self_call then
-      Don't_try_it S.Not_specialised.Self_call
     else if remaining_inlining_threshold = T.Never_inline then
       let threshold =
         match inlining_threshold with
@@ -528,9 +528,10 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
   in
   if function_decl.stub then
     let body, r =
-      Inlining_transforms.inline_by_copying_function_body ~env ~r
-        ~function_decls ~lhs_of_application ~closure_id_being_applied
-        ~inline_requested ~specialise_requested ~function_decl ~args ~simplify
+      Inlining_transforms.inline_by_copying_function_body ~env
+        ~r ~function_decls ~lhs_of_application
+        ~closure_id_being_applied ~specialise_requested ~inline_requested
+        ~function_decl ~args ~dbg ~simplify
     in
     simplify env r body
   else if E.never_inline env then
@@ -542,7 +543,7 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
     let env = E.unset_never_inline_inside_closures env in
     let env =
       E.note_entering_call env
-        ~closure_id:closure_id_being_applied ~debuginfo:dbg
+        ~closure_id:closure_id_being_applied ~dbg:dbg
     in
     let max_level =
       Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth
@@ -629,7 +630,7 @@ let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
               ~closure_id_being_applied ~function_decl ~value_set_of_closures
               ~only_use_of_function ~original ~recursive
               ~inline_requested ~specialise_requested ~args
-              ~size_from_approximation ~simplify ~fun_cost ~self_call
+              ~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call
               ~inlining_threshold
           in
           match inline_result with

diff --git a/middle_end/inlining_stats.ml b/middle_end/inlining_stats.ml
index d0d18fc80f0336b0cc5a18e977a19f61fbe6be58..0c7cc03346be4f5294c1501ac92d41b1bdcf3f9a 100644 (file)
--- a/middle_end/inlining_stats.ml
+++ b/middle_end/inlining_stats.ml
@@ -27,23 +27,23 @@ module Closure_stack = struct
 
   let create () = []
 
-  let note_entering_closure t ~closure_id ~debuginfo =
+  let note_entering_closure t ~closure_id ~dbg =
     if not !Clflags.inlining_report then t
     else
       match t with
       | [] | (Closure _ | Inlined | Specialised _)  :: _->
-        (Closure (closure_id, debuginfo)) :: t
+        (Closure (closure_id, dbg)) :: t
       | (Call _) :: _ ->
         Misc.fatal_errorf "note_entering_closure: unexpected Call node"
 
   (* CR-someday lwhite: since calls do not have a unique id it is possible
      some calls will end up sharing nodes. *)
-  let note_entering_call t ~closure_id ~debuginfo =
+  let note_entering_call t ~closure_id ~dbg =
     if not !Clflags.inlining_report then t
     else
       match t with
       | [] | (Closure _ | Inlined | Specialised _) :: _ ->
-        (Call (closure_id, debuginfo)) :: t
+        (Call (closure_id, dbg)) :: t
       | (Call _) :: _ ->
         Misc.fatal_errorf "note_entering_call: unexpected Call node"
 
@@ -91,13 +91,7 @@ module Inlining_report = struct
     type t = Debuginfo.t * Closure_id.t * kind
 
     let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) =
-      let c = compare d1.dinfo_file d2.dinfo_file in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_line d2.dinfo_line in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_char_end d2.dinfo_char_end in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_char_start d2.dinfo_char_start in
+      let c = Debuginfo.compare d1 d2 in
       if c <> 0 then c else
       let c = Closure_id.compare cl1 cl2 in
       if c <> 0 then c else

diff --git a/middle_end/inlining_stats.mli b/middle_end/inlining_stats.mli
index b0716a2a940d7477abba062c8cda01760fa89776..f1e84fdcea37b466fec9db273466ac4b490e1a8b 100644 (file)
--- a/middle_end/inlining_stats.mli
+++ b/middle_end/inlining_stats.mli
@@ -24,13 +24,13 @@ module Closure_stack : sig
   val note_entering_closure
      : t
     -> closure_id:Closure_id.t
-    -> debuginfo:Debuginfo.t
+    -> dbg:Debuginfo.t
     -> t
 
   val note_entering_call
     : t
     -> closure_id:Closure_id.t
-    -> debuginfo:Debuginfo.t
+    -> dbg:Debuginfo.t
     -> t
 
   val note_entering_inlined : t -> t

diff --git a/middle_end/inlining_transforms.ml b/middle_end/inlining_transforms.ml
old mode 100644 (file)
new mode 100755 (executable)
index 58c2442..d2bcd62
--- a/middle_end/inlining_transforms.ml
+++ b/middle_end/inlining_transforms.ml
@@ -16,7 +16,6 @@
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
 
-module A = Simple_value_approx
 module B = Inlining_cost.Benefit
 module E = Inline_and_simplify_aux.Env
 module R = Inline_and_simplify_aux.Result
@@ -116,7 +115,7 @@ let inline_by_copying_function_body ~env ~r
       ~(inline_requested : Lambda.inline_attribute)
       ~(specialise_requested : Lambda.specialise_attribute)
       ~closure_id_being_applied
-      ~(function_decl : Flambda.function_declaration) ~args ~simplify =
+      ~(function_decl : Flambda.function_declaration) ~args ~dbg ~simplify =
   assert (E.mem env lhs_of_application);
   assert (List.for_all (E.mem env) args);
   let r =
@@ -175,6 +174,7 @@ let inline_by_copying_function_body ~env ~r
       bindings_for_vars_bound_by_closure_and_params_to_args
   in
   let env = E.activate_freshening (E.set_never_inline env) in
+  let env = E.set_inline_debuginfo ~dbg env in
   simplify env r expr
 
 let inline_by_copying_function_declaration ~env ~r
@@ -187,6 +187,19 @@ let inline_by_copying_function_declaration ~env ~r
     ~(invariant_params:Variable.Set.t Variable.Map.t lazy_t)
     ~(specialised_args : Flambda.specialised_to Variable.Map.t)
     ~direct_call_surrogates ~dbg ~simplify =
+  let function_decls =
+    (* To simplify a substitution (see comment below), rewrite any references
+       to closures in the set being defined that go via symbols, so they go
+       via closure variables instead. *)
+    let make_closure_symbol =
+      let module Backend = (val (E.backend env) : Backend_intf.S) in
+      Backend.closure_symbol
+    in
+    Freshening.rewrite_recursive_calls_with_symbols
+      (Freshening.activate Freshening.empty)
+      ~make_closure_symbol
+      function_decls
+  in
   let original_function_decls = function_decls in
   let specialised_args_set = Variable.Map.keys specialised_args in
   let worth_specialising_args, specialisable_args, args, args_decl =
@@ -197,7 +210,7 @@ let inline_by_copying_function_declaration ~env ~r
   in
   (* Arguments of functions that are not directly called but are
      aliased to arguments of a directly called one may need to be
-     marked as specialiased. *)
+     marked as specialised. *)
   let specialisable_args_with_aliases =
     Variable.Map.fold (fun arg outside_var map ->
         match Variable.Map.find arg (Lazy.force invariant_params) with
@@ -275,6 +288,32 @@ let inline_by_copying_function_declaration ~env ~r
           Variable.Set.mem func required_functions)
         function_decls.funs
     in
+    let free_vars, free_vars_for_lets, original_vars =
+      (* Bind all the closures from the original (non-specialised) set as
+         free variables in the set.  This means that we can reference them
+         when some particular recursive call cannot be specialised.  See
+         detailed comment below. *)
+      Variable.Map.fold (fun fun_var _fun_decl
+                (free_vars, free_vars_for_lets, original_vars) ->
+          let var = Variable.create "closure" in
+          let original_closure : Flambda.named =
+            Move_within_set_of_closures
+              { closure = lhs_of_application;
+                start_from = closure_id_being_applied;
+                move_to = Closure_id.wrap fun_var;
+              }
+          in
+          let internal_var = Variable.rename ~append:"_original" fun_var in
+          let free_vars =
+            Variable.Map.add internal_var { Flambda. var; projection = None }
+              free_vars
+          in
+          free_vars,
+            (var, original_closure) :: free_vars_for_lets,
+            Variable.Map.add fun_var internal_var original_vars)
+        funs
+        (free_vars, free_vars_for_lets, Variable.Map.empty)
+    in
     let direct_call_surrogates =
       Closure_id.Map.fold (fun existing surrogate surrogates ->
           let existing = Closure_id.unwrap existing in
@@ -339,6 +378,119 @@ let inline_by_copying_function_declaration ~env ~r
               None)
         specialisable_args_with_aliases specialised_args
     in
+    let functions'_specialised_params =
+      Flambda_utils.parameters_specialised_to_the_same_variable
+        ~function_decls
+        ~specialised_args:specialisable_args
+    in
+    let rewrite_function (fun_decl:Flambda.function_declaration) =
+      (* First rewrite every use of the closure(s) defined by the current set
+         of closures to free variable(s) corresponding to the original
+         (non-specialised) closure(s).
+
+         Then for each call to such closures, if the arguments to the call are
+         obviously the same as the arguments to which we are specialising the
+         function, redirect the call to the specialised function.
+
+         In a function like [List.map]:
+         {[
+           let rec specialised_map f l =
+             match l with
+             | [] -> []
+             | h :: t -> f h :: specialised_map f t
+         ]} ( with [f] a specialised argument )
+
+         The first step turns it into:
+         {[
+           let map_original = map in
+           let rec specialised_map f l =
+             match l with
+             | [] -> []
+             | h :: t -> f h :: map_original f t
+         ]}
+         and the second recognizes the call to [map_original] as a call
+         preserving the specialised arguments (here [f]). So it is
+         replaced by [specialised_map f t].
+
+         In the case of [map] this is a circuituous means of achieving the
+         desired result, but in general, this provides a way of handling
+         situations where some recursive calls (for example in subfunctions)
+         are made with arguments different from the specialised arguments.
+         The two-pass approach is convenient since the first pass performs
+         a correct code transformation without optimisation; and then the
+         second just performs the optimisation on a best-effort basis.
+      *)
+      let body_substituted =
+        (* The use of [Freshening.rewrite_recursive_calls_with_symbols] above
+           ensures that we catch all calls to the functions being defined
+           in the current set of closures. *)
+        Flambda_utils.toplevel_substitution original_vars fun_decl.body
+      in
+      let body =
+        Flambda_iterators.map_toplevel_expr (fun (expr : Flambda.t) ->
+            match expr with
+            | Apply apply ->
+              begin match apply.kind with
+              | Indirect -> expr
+              | Direct closure_id ->
+                (* We recognize the potential recursive calls using the
+                   closure ID rather than [apply.func] because the latter can be
+                   aliases to the function (through a symbol for instance; the
+                   fact that we've now rewritten such symbols to variables
+                   doesn't squash any aliases) rather than being the closure var
+                   directly. *)
+                let closure_var = Closure_id.unwrap closure_id in
+                begin match
+                  Variable.Map.find closure_var functions'_specialised_params
+                with
+                | exception Not_found -> expr
+                | specialised_params ->
+                  (* This is a call to one of the functions from the set being
+                     specialised. *)
+                  let apply_is_preserving_specialised_args =
+                    List.length apply.args = List.length specialised_params
+                      && List.for_all2 (fun arg param ->
+                          match
+                            (arg : Flambda_utils.specialised_to_same_as)
+                          with
+                          | Not_specialised -> true
+                          | Specialised_and_aliased_to args ->
+                            (* This is using one of the aliases of [param]. This
+                               is not necessarily the exact same variable as
+                               the original parameter---in particular when the
+                               set contains multiply-recursive functions. *)
+                            Variable.Set.mem param args)
+                        specialised_params
+                        apply.args
+                  in
+                  if apply_is_preserving_specialised_args then
+                    Flambda.Apply
+                      { apply with
+                        func = closure_var;
+                        kind = Direct closure_id;
+                      }
+                  else
+                    expr
+                end
+              end
+            | _ -> expr)
+          body_substituted
+      in
+      Flambda.create_function_declaration
+        ~params:fun_decl.params
+        ~stub:fun_decl.stub
+        ~dbg:fun_decl.dbg
+        ~inline:fun_decl.inline
+        ~specialise:fun_decl.specialise
+        ~is_a_functor:fun_decl.is_a_functor
+        ~body
+    in
+    let funs =
+      Variable.Map.map rewrite_function function_decls.funs
+    in
+    let function_decls =
+      Flambda.update_function_declarations ~funs function_decls
+    in
     let set_of_closures =
       (* This is the new set of closures, with more precise specialisation
          information than the one being copied. *)

diff --git a/middle_end/inlining_transforms.mli b/middle_end/inlining_transforms.mli
index 3995a975d61fa06bdf30647a06d5adbbbb6e1059..b86716ac1db5954bef3d8bbe4c9308d6697493c1 100644 (file)
--- a/middle_end/inlining_transforms.mli
+++ b/middle_end/inlining_transforms.mli
@@ -74,6 +74,7 @@ val inline_by_copying_function_body
   -> closure_id_being_applied:Closure_id.t
   -> function_decl:Flambda.function_declaration
   -> args:Variable.t list
+  -> dbg:Debuginfo.t
   -> simplify:Inlining_decision_intf.simplify
   -> Flambda.t * Inline_and_simplify_aux.Result.t
 

diff --git a/middle_end/invariant_params.ml b/middle_end/invariant_params.ml
old mode 100644 (file)
new mode 100755 (executable)
index 76e4b3e..5011417
--- a/middle_end/invariant_params.ml
+++ b/middle_end/invariant_params.ml
@@ -278,7 +278,7 @@ let analyse_functions ~backend ~param_to_param
      let rec f x = ...
      and g y = f x
 
-   We record [(f, x) <- Top] when some unknown values can flow to a the
+   We record [(f, x) <- Top] when some unknown values can flow to the
    [y] parameter.
 
      let rec f x = f 1

diff --git a/middle_end/lift_code.ml b/middle_end/lift_code.ml
index 4098c23a544bd04f2fd5acffa4f824261ec05dc4..070bde9efc99ad8174fb3909376a6cc82dab3aa0 100644 (file)
--- a/middle_end/lift_code.ml
+++ b/middle_end/lift_code.ml
@@ -16,9 +16,6 @@
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
 
-module A = Simple_value_approx
-module C = Inlining_cost
-
 type lifter = Flambda.program -> Flambda.program
 
 let rebuild_let

diff --git a/middle_end/lift_constants.ml b/middle_end/lift_constants.ml
index d9b26d41f4f9dc7bf1517392b59c132096c34c58..6d137e195a5473ecb1f03dbf63fb69560d9eb6f9 100644 (file)
--- a/middle_end/lift_constants.ml
+++ b/middle_end/lift_constants.ml
@@ -20,7 +20,7 @@
 let rec tail_variable : Flambda.t -> Variable.t option = function
   | Var v -> Some v
   | Let_rec (_, e)
-  | Let_mutable (_, _, e)
+  | Let_mutable { body = e }
   | Let { body = e; _ } -> tail_variable e
   | _ -> None
 
@@ -63,7 +63,7 @@ let assign_symbols_and_collect_constant_definitions
         (* [Inconstant_idents] always marks these expressions as
            inconstant, so we should never get here. *)
         assert false
-      | Prim (Pmakeblock (tag, _), fields, _) ->
+      | Prim (Pmakeblock (tag, _, _value_kind), fields, _) ->
         assign_symbol ();
         record_definition (AA.Block (Tag.create_exn tag, fields))
       | Read_symbol_field (symbol, field) ->
@@ -302,26 +302,30 @@ let translate_definition_and_resolve_alias inconstants
         [Array (Pfloatarray, _, _)]
        (which references its contents via variables; it does not contain
         manifest floats). *)
+    let find_float_var_definition var =
+      match Variable.Tbl.find var_to_definition_tbl var with
+      | Allocated_const (Normal (Float f)) -> f
+      | const_defining_value ->
+          Misc.fatal_errorf "Bad definition for float array member %a: %a"
+            Variable.print var
+            Alias_analysis.print_constant_defining_value
+            const_defining_value
+    in
+    let find_float_symbol_definition sym =
+      match Symbol.Map.find sym symbol_definition_map with
+      | Allocated_const (Float f) -> f
+      | const_defining_value ->
+          Misc.fatal_errorf "Bad definition for float array member %a: %a"
+            Symbol.print sym
+            Flambda.print_constant_defining_value
+            const_defining_value
+    in
     let floats =
       List.map (fun var ->
-          let var =
-            match Variable.Map.find var aliases with
-            | exception Not_found -> var
-            | Symbol _ ->
-              Misc.fatal_errorf
-                "Lift_constants.translate_definition_and_resolve_alias: \
-                  Array Pfloatarray %a with Symbol argument: %a"
-                Variable.print var
-                Alias_analysis.print_constant_defining_value definition
-            | Variable var -> var
-          in
-          match Variable.Tbl.find var_to_definition_tbl var with
-          | Allocated_const (Normal (Float f)) -> f
-          | const_defining_value ->
-            Misc.fatal_errorf "Bad definition for float array member %a: %a"
-              Variable.print var
-              Alias_analysis.print_constant_defining_value
-                const_defining_value)
+          match Variable.Map.find var aliases with
+          | exception Not_found -> find_float_var_definition var
+          | Variable var -> find_float_var_definition var
+          | Symbol sym -> find_float_symbol_definition sym)
         vars
     in
     let const : Allocated_const.t =
@@ -379,14 +383,9 @@ let translate_definition_and_resolve_alias inconstants
                Duplicate Pfloatarray %a with unknown symbol: %a"
               Variable.print var
               Alias_analysis.print_constant_defining_value definition
-          | Value_float_array { contents = Contents float_array } ->
+          | Value_float_array value_float_array ->
             let contents =
-              Array.fold_right (fun elt acc ->
-                  match acc, elt with
-                  | None, _ | _, None -> None
-                  | Some acc, Some f ->
-                    Some (f :: acc))
-                float_array (Some [])
+              Simple_value_approx.float_array_as_constant value_float_array
             in
             begin match contents with
             | None ->

diff --git a/middle_end/lift_let_to_initialize_symbol.ml b/middle_end/lift_let_to_initialize_symbol.ml
index 337d0193acefd3c311120cb07da22e90a967ab43..d573f5469053f18ef0a8b5c6cdbde0e54690d157 100644 (file)
--- a/middle_end/lift_let_to_initialize_symbol.ml
+++ b/middle_end/lift_let_to_initialize_symbol.ml
@@ -80,7 +80,7 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets
     let extracted =
       let renamed = Variable.rename var in
       match named with
-      | Prim (Pmakeblock (tag, Asttypes.Immutable), args, _dbg) ->
+      | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind), args, _dbg) ->
         let tag = Tag.create_exn tag in
         let args =
           List.map (fun v ->
@@ -125,7 +125,7 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets
         Flambda_utils.toplevel_substitution def_substitution
           (Let_rec (renamed_defs,
                     Flambda_utils.name_expr ~name:"lifted_let_rec_block"
-                      (Prim (Pmakeblock (0, Immutable),
+                      (Prim (Pmakeblock (0, Immutable, None),
                              List.map fst renamed_defs,
                              Debuginfo.none))))
       in

diff --git a/middle_end/projection.ml b/middle_end/projection.ml
index deb864889018f94f4c5b0a223be9dfcc211fa4ee..8183727d77e38783ab3d6f911b9db0a394e6efac 100644 (file)
--- a/middle_end/projection.ml
+++ b/middle_end/projection.ml
@@ -116,7 +116,7 @@ include Identifiable.Make (struct
     | Project_closure _, _ -> -1
     | _, Project_closure _ -> 1
     | Move_within_set_of_closures _, _ -> -1
-    | _, Move_within_set_of_closures _ -> -1
+    | _, Move_within_set_of_closures _ -> 1
 
   let equal t1 t2 =
     (compare t1 t2) = 0

diff --git a/middle_end/ref_to_variables.ml b/middle_end/ref_to_variables.ml
index 0b79b1cab7f13c98f62b8a7ebdac3b42478b2e14..a59563e2ed67129ca4b5c52e5962d4c3e28fa8d5 100644 (file)
--- a/middle_end/ref_to_variables.ml
+++ b/middle_end/ref_to_variables.ml
@@ -54,7 +54,7 @@ let variables_not_used_as_local_reference (tree:Flambda.t) =
       loop body
     | Var v ->
       set := Variable.Set.add v !set
-    | Let_mutable (_, v, body) ->
+    | Let_mutable { initial_value = v; body } ->
       set := Variable.Set.add v !set;
       loop body
     | If_then_else (cond, ifso, ifnot) ->
@@ -96,7 +96,7 @@ let variables_containing_ref (flam:Flambda.t) =
   let aux (flam : Flambda.t) =
     match flam with
     | Let { var;
-            defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable), l, _);
+            defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, _), l, _);
           } ->
       map := Variable.Map.add var (List.length l) !map
     | _ -> ()
@@ -132,17 +132,24 @@ let eliminate_ref_of_expr flam =
     let aux (flam : Flambda.t) : Flambda.t =
       match flam with
       | Let { var;
-              defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable), l, _);
+              defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, shape), l,_);
               body }
         when convertible_variable var ->
+        let shape = match shape with
+          | None -> List.map (fun _ -> Lambda.Pgenval) l
+          | Some shape -> shape
+        in
         let _, expr =
-          List.fold_left (fun (field,body) init ->
+          List.fold_left2 (fun (field,body) init kind ->
               match get_variable var field with
               | None -> assert false
               | Some (field_var, _) ->
                 field+1,
-                ((Let_mutable (field_var, init, body)) : Flambda.t))
-            (0,body) l in
+                (Let_mutable { var = field_var;
+                               initial_value = init;
+                               body;
+                               contents_kind = kind } : Flambda.t))
+            (0,body) l shape in
         expr
       | Let _ | Let_mutable _
       | Assign _ | Var _ | Apply _

diff --git a/middle_end/remove_free_vars_equal_to_args.ml b/middle_end/remove_free_vars_equal_to_args.ml
old mode 100644 (file)
new mode 100755 (executable)
index d5df14b..6b3b59d
--- a/middle_end/remove_free_vars_equal_to_args.ml
+++ b/middle_end/remove_free_vars_equal_to_args.ml
@@ -34,7 +34,7 @@ let rewrite_one_function_decl ~(function_decl : Flambda.function_declaration)
             (* No free variables equal to the param *)
             subst
           | set ->
-            (* Replace the free variables equal to an parameter *)
+            (* Replace the free variables equal to a parameter *)
             Variable.Set.fold (fun free_var subst ->
                 Variable.Map.add free_var param subst)
               set subst)

diff --git a/middle_end/remove_unused_arguments.ml b/middle_end/remove_unused_arguments.ml
index cfac16e35ac4a407b52e53ec472ab077f9313371..42f1c0ffe6022ff0edad23c45c6aa31aecb6944f 100644 (file)
--- a/middle_end/remove_unused_arguments.ml
+++ b/middle_end/remove_unused_arguments.ml
@@ -78,13 +78,12 @@ let make_stub unused var (fun_decl : Flambda.function_declaration)
   in
   let args = List.map (fun (_, var) -> var) used_args' in
   let kind = Flambda.Direct (Closure_id.wrap renamed) in
-  let dbg = fun_decl.dbg in
   let body : Flambda.t =
     Apply {
       func = renamed;
       args;
       kind;
-      dbg;
+      dbg = fun_decl.dbg;
       inline = Default_inline;
       specialise = Default_specialise;
     }

diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml
index b8b8c51da2619cb03c423e5a8fe7afa723b15494..3cedc03f612f217b0eb788a78ddeeb1bdf66e1f8 100644 (file)
--- a/middle_end/semantics_of_primitives.ml
+++ b/middle_end/semantics_of_primitives.ml
@@ -21,7 +21,8 @@ type coeffects = No_coeffects | Has_coeffects
 
 let for_primitive (prim : Lambda.primitive) =
   match prim with
-  | Pignore | Pidentity -> No_effects, No_coeffects
+  | Pignore | Pidentity | Pbytes_to_string | Pbytes_of_string ->
+    No_effects, No_coeffects
   | Pmakeblock _
   | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects
   | Pmakearray (_, Immutable) -> No_effects, No_coeffects
@@ -49,9 +50,16 @@ let for_primitive (prim : Lambda.primitive) =
   | Plsrint
   | Pasrint
   | Pintcomp _ -> No_effects, No_coeffects
-  | Pdivint
-  | Pmodint ->
+  | Pdivbint { is_safe = Unsafe }
+  | Pmodbint { is_safe = Unsafe }
+  | Pdivint Unsafe
+  | Pmodint Unsafe ->
     No_effects, No_coeffects  (* Will not raise [Division_by_zero]. *)
+  | Pdivbint { is_safe = Safe }
+  | Pmodbint { is_safe = Safe }
+  | Pdivint Safe
+  | Pmodint Safe ->
+    Arbitrary_effects, No_coeffects
   | Poffsetint _ -> No_effects, No_coeffects
   | Poffsetref _ -> Arbitrary_effects, Has_coeffects
   | Pintoffloat
@@ -63,7 +71,7 @@ let for_primitive (prim : Lambda.primitive) =
   | Pmulfloat
   | Pdivfloat
   | Pfloatcomp _ -> No_effects, No_coeffects
-  | Pstringlength
+  | Pstringlength | Pbyteslength
   | Parraylength _ ->
     No_effects, Has_coeffects  (* That old chestnut: [Obj.truncate]. *)
   | Pisint
@@ -76,8 +84,6 @@ let for_primitive (prim : Lambda.primitive) =
   | Paddbint _
   | Psubbint _
   | Pmulbint _
-  | Pdivbint _
-  | Pmodbint _
   | Pandbint _
   | Porbint _
   | Pxorbint _
@@ -92,6 +98,7 @@ let for_primitive (prim : Lambda.primitive) =
   | Pgetglobal _
   | Parrayrefu _
   | Pstringrefu
+  | Pbytesrefu
   | Pstring_load_16 true
   | Pstring_load_32 true
   | Pstring_load_64 true
@@ -102,6 +109,7 @@ let for_primitive (prim : Lambda.primitive) =
     No_effects, Has_coeffects
   | Parrayrefs _
   | Pstringrefs
+  | Pbytesrefs
   | Pstring_load_16 false
   | Pstring_load_32 false
   | Pstring_load_64 false
@@ -116,8 +124,8 @@ let for_primitive (prim : Lambda.primitive) =
   | Psetglobal _
   | Parraysetu _
   | Parraysets _
-  | Pstringsetu
-  | Pstringsets
+  | Pbytessetu
+  | Pbytessets
   | Pstring_set_16 _
   | Pstring_set_32 _
   | Pstring_set_64 _
@@ -135,10 +143,30 @@ let for_primitive (prim : Lambda.primitive) =
   | Popaque -> Arbitrary_effects, Has_coeffects
   | Ploc _ ->
     Misc.fatal_error "[Ploc] should have been eliminated by [Translcore]"
-  | Prevapply _
-  | Pdirapply _
+  | Prevapply
+  | Pdirapply
   | Psequand
   | Psequor ->
     Misc.fatal_errorf "The primitive %a should have been eliminated by the \
         [Closure_conversion] pass."
       Printlambda.primitive prim
+
+type return_type =
+  | Float
+  | Other
+
+let return_type_of_primitive (prim:Lambda.primitive) =
+  match prim with
+  | Pfloatofint
+  | Pnegfloat
+  | Pabsfloat
+  | Paddfloat
+  | Psubfloat
+  | Pmulfloat
+  | Pdivfloat
+  | Pfloatfield _
+  | Parrayrefu Pfloatarray
+  | Parrayrefs Pfloatarray ->
+    Float
+  | _ ->
+    Other

diff --git a/middle_end/semantics_of_primitives.mli b/middle_end/semantics_of_primitives.mli
index 652317330289e8c122c04d81ae47b934f44a2a3e..32205cee75bc2d38cf9f0696e5efbe1597558441 100644 (file)
--- a/middle_end/semantics_of_primitives.mli
+++ b/middle_end/semantics_of_primitives.mli
@@ -63,3 +63,9 @@ type coeffects = No_coeffects | Has_coeffects
 val for_primitive
    : Lambda.primitive
   -> effects * coeffects
+
+type return_type =
+  | Float
+  | Other
+
+val return_type_of_primitive : Lambda.primitive -> return_type

diff --git a/middle_end/simple_value_approx.ml b/middle_end/simple_value_approx.ml
index 50de3181738df4f4aefcda7a7fbb4b24c580a702..4d9284661dcaf3ea41b0f2ab4649e8eabae0c3ab 100644 (file)
--- a/middle_end/simple_value_approx.ml
+++ b/middle_end/simple_value_approx.ml
@@ -29,15 +29,6 @@ type value_string = {
   size : int;
 }
 
-type value_float_array_contents =
-  | Contents of float option array
-  | Unknown_or_mutable
-
-type value_float_array = {
-  contents : value_float_array_contents;
-  size : int;
-}
-
 type unknown_because_of =
   | Unresolved_symbol of Symbol.t
   | Other
@@ -53,7 +44,7 @@ and descr =
   | Value_int of int
   | Value_char of char
   | Value_constptr of int
-  | Value_float of float
+  | Value_float of float option
   | Value_boxed_int : 'a boxed_int * 'a -> descr
   | Value_set_of_closures of value_set_of_closures
   | Value_closure of value_closure
@@ -80,6 +71,15 @@ and value_set_of_closures = {
   direct_call_surrogates : Closure_id.t Closure_id.Map.t;
 }
 
+and value_float_array_contents =
+  | Contents of t array
+  | Unknown_or_mutable
+
+and value_float_array = {
+  contents : value_float_array_contents;
+  size : int;
+}
+
 let descr t = t.descr
 
 let print_value_set_of_closures ppf
@@ -113,7 +113,8 @@ let rec print_descr ppf = function
     print_value_set_of_closures ppf set_of_closures
   | Value_unresolved sym ->
     Format.fprintf ppf "(unresolved %a)" Symbol.print sym
-  | Value_float f -> Format.pp_print_float ppf f
+  | Value_float (Some f) -> Format.pp_print_float ppf f
+  | Value_float None -> Format.pp_print_string ppf "float"
   | Value_string { contents; size } -> begin
       match contents with
       | None ->
@@ -161,11 +162,48 @@ let augment_with_symbol_field t symbol field =
   | Some _ -> t
 let replace_description t descr = { t with descr }
 
+let augment_with_kind t (kind:Lambda.value_kind) =
+  match kind with
+  | Pgenval -> t
+  | Pfloatval ->
+    begin match t.descr with
+    | Value_float _ ->
+      t
+    | Value_unknown _ | Value_unresolved _ ->
+      { t with descr = Value_float None }
+    | Value_block _
+    | Value_int _
+    | Value_char _
+    | Value_constptr _
+    | Value_boxed_int _
+    | Value_set_of_closures _
+    | Value_closure _
+    | Value_string _
+    | Value_float_array _
+    | Value_bottom ->
+      (* Unreachable *)
+      { t with descr = Value_bottom }
+    | Value_extern _ | Value_symbol _ ->
+      (* We don't know yet *)
+      t
+    end
+  | _ -> t
+
+let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind =
+  match t.descr with
+  | Value_float _ -> Pfloatval
+  | Value_int _ -> Pintval
+  | Value_boxed_int (Int32, _) -> Pboxedintval Pint32
+  | Value_boxed_int (Int64, _) -> Pboxedintval Pint64
+  | Value_boxed_int (Nativeint, _) -> Pboxedintval Pnativeint
+  | _ -> kind
+
 let value_unknown reason = approx (Value_unknown reason)
 let value_int i = approx (Value_int i)
 let value_char i = approx (Value_char i)
 let value_constptr i = approx (Value_constptr i)
-let value_float f = approx (Value_float f)
+let value_float f = approx (Value_float (Some f))
+let value_any_float = approx (Value_float None)
 let value_boxed_int bi i = approx (Value_boxed_int (bi,i))
 
 let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol
@@ -239,8 +277,11 @@ let value_unresolved sym = approx (Value_unresolved sym)
 let value_string size contents = approx (Value_string {size; contents })
 let value_mutable_float_array ~size =
   approx (Value_float_array { contents = Unknown_or_mutable; size; } )
-let value_immutable_float_array contents =
+let value_immutable_float_array (contents:t array) =
   let size = Array.length contents in
+  let contents =
+    Array.map (fun t -> augment_with_kind t Pfloatval) contents
+  in
   approx (Value_float_array { contents = Contents contents; size; } )
 
 let name_expr_fst (named, thing) ~name =
@@ -314,7 +355,7 @@ let simplify t (lam : Flambda.t) : simplification_result =
     | Value_constptr n ->
       let const, approx = make_const_ptr n in
       const, Replaced_term, approx
-    | Value_float f ->
+    | Value_float (Some f) ->
       let const, approx = make_const_float f in
       const, Replaced_term, approx
     | Value_boxed_int (t, i) ->
@@ -322,7 +363,7 @@ let simplify t (lam : Flambda.t) : simplification_result =
       const, Replaced_term, approx
     | Value_symbol sym ->
       U.name_expr (Symbol sym) ~name:"symbol", Replaced_term, t
-    | Value_string _ | Value_float_array _
+    | Value_string _ | Value_float_array _ | Value_float None
     | Value_block _ | Value_set_of_closures _ | Value_closure _
     | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ ->
       lam, Nothing_done, t
@@ -341,7 +382,7 @@ let simplify_named t (named : Flambda.named) : simplification_result_named =
     | Value_constptr n ->
       let const, approx = make_const_ptr_named n in
       const, Replaced_term, approx
-    | Value_float f ->
+    | Value_float (Some f) ->
       let const, approx = make_const_float_named f in
       const, Replaced_term, approx
     | Value_boxed_int (t, i) ->
@@ -349,7 +390,7 @@ let simplify_named t (named : Flambda.named) : simplification_result_named =
       const, Replaced_term, approx
     | Value_symbol sym ->
       Symbol sym, Replaced_term, t
-    | Value_string _ | Value_float_array _
+    | Value_string _ | Value_float_array _ | Value_float None
     | Value_block _ | Value_set_of_closures _ | Value_closure _
     | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ ->
       named, Nothing_done, t
@@ -363,10 +404,10 @@ let simplify_var t : (Flambda.named * t) option =
   | Value_int n -> Some (make_const_int_named n)
   | Value_char n -> Some (make_const_char_named n)
   | Value_constptr n -> Some (make_const_ptr_named n)
-  | Value_float f -> Some (make_const_float_named f)
+  | Value_float (Some f) -> Some (make_const_float_named f)
   | Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i)
   | Value_symbol sym -> Some (Symbol sym, t)
-  | Value_string _ | Value_float_array _
+  | Value_string _ | Value_float_array _ | Value_float None
   | Value_block _ | Value_set_of_closures _ | Value_closure _
   | Value_unknown _ | Value_bottom | Value_extern _
   | Value_unresolved _ ->
@@ -541,7 +582,7 @@ let equal_boxed_int (type t1) (type t2)
    rewriting [Project_var] and [Project_closure] constructions
    in [Flambdainline.loop]
 *)
-let rec meet_descr d1 d2 = match d1, d2 with
+let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with
   | Value_int i, Value_int j when i = j ->
       d1
   | Value_constptr i, Value_constptr j when i = j ->
@@ -557,13 +598,20 @@ let rec meet_descr d1 d2 = match d1, d2 with
       d1
   | Value_block (tag1, a1), Value_block (tag2, a2)
     when tag1 = tag2 && Array.length a1 = Array.length a2 ->
-      Value_block (tag1, Array.mapi (fun i v -> meet v a2.(i)) a1)
+    let fields =
+      Array.mapi (fun i v -> meet ~really_import_approx v a2.(i)) a1
+    in
+    Value_block (tag1, fields)
   | _ -> Value_unknown Other
 
-and meet a1 a2 =
+and meet ~really_import_approx a1 a2 =
   match a1, a2 with
   | { descr = Value_bottom }, a
   | a, { descr = Value_bottom } -> a
+  | { descr = (Value_symbol _ | Value_extern _) }, _
+  | _, { descr = (Value_symbol _ | Value_extern _) } ->
+    meet ~really_import_approx
+      (really_import_approx a1) (really_import_approx a2)
   | _ ->
       let var =
         match a1.var, a2.var with
@@ -585,7 +633,7 @@ and meet a1 a2 =
               | _ -> None
             else None
       in
-      { descr = meet_descr a1.descr a2.descr;
+      { descr = meet_descr ~really_import_approx a1.descr a2.descr;
         var;
         symbol }
 
@@ -710,10 +758,92 @@ let approx_for_bound_var value_set_of_closures var =
 
 let check_approx_for_float t : float option =
   match t.descr with
-  | Value_float f -> Some f
+  | Value_float f -> f
   | Value_unresolved _
   | Value_unknown _ | Value_string _ | Value_float_array _
   | Value_bottom | Value_block _ | Value_int _ | Value_char _
   | Value_constptr _ | Value_set_of_closures _ | Value_closure _
   | Value_extern _ | Value_boxed_int _ | Value_symbol _ ->
       None
+
+let float_array_as_constant (t:value_float_array) : float list option =
+  match t.contents with
+  | Unknown_or_mutable -> None
+  | Contents contents ->
+    Array.fold_right (fun elt acc ->
+      match acc, elt.descr with
+      | Some acc, Value_float (Some f) ->
+        Some (f :: acc)
+      | None, _
+      | Some _,
+        (Value_float None | Value_unresolved _
+        | Value_unknown _ | Value_string _ | Value_float_array _
+        | Value_bottom | Value_block _ | Value_int _ | Value_char _
+        | Value_constptr _ | Value_set_of_closures _ | Value_closure _
+        | Value_extern _ | Value_boxed_int _ | Value_symbol _)
+        -> None)
+      contents (Some [])
+
+let check_approx_for_string t : string option =
+  match t.descr with
+  | Value_string { contents } -> contents
+  | Value_float _
+  | Value_unresolved _
+  | Value_unknown _ | Value_float_array _
+  | Value_bottom | Value_block _ | Value_int _ | Value_char _
+  | Value_constptr _ | Value_set_of_closures _ | Value_closure _
+  | Value_extern _ | Value_boxed_int _ | Value_symbol _ ->
+      None
+
+type switch_branch_selection =
+  | Cannot_be_taken
+  | Can_be_taken
+  | Must_be_taken
+
+let potentially_taken_const_switch_branch t branch =
+  match t.descr with
+  | Value_unresolved _
+  | Value_unknown _
+  | Value_extern _
+  | Value_symbol _ ->
+    (* In theory symbol cannot contain integers but this shouldn't
+       matter as this will always be an imported approximation *)
+    Can_be_taken
+  | Value_constptr i | Value_int i when i = branch ->
+    Must_be_taken
+  | Value_char c when Char.code c = branch ->
+    Must_be_taken
+  | Value_constptr _ | Value_int _ | Value_char _ ->
+    Cannot_be_taken
+  | Value_block _ | Value_float _ | Value_float_array _
+  | Value_string _ | Value_closure _ | Value_set_of_closures _
+  | Value_boxed_int _ | Value_bottom ->
+    Cannot_be_taken
+
+let potentially_taken_block_switch_branch t tag =
+  match t.descr with
+  | (Value_unresolved _
+    | Value_unknown _
+    | Value_extern _
+    | Value_symbol _) ->
+    Can_be_taken
+  | (Value_constptr _ | Value_int _| Value_char _) ->
+    Cannot_be_taken
+  | Value_block (block_tag, _) when Tag.to_int block_tag = tag ->
+    Must_be_taken
+  | Value_float _ when tag = Obj.double_tag ->
+    Must_be_taken
+  | Value_float_array _ when tag = Obj.double_array_tag ->
+    Must_be_taken
+  | Value_string _ when tag = Obj.string_tag ->
+    Must_be_taken
+  | (Value_closure _ | Value_set_of_closures _)
+    when tag = Obj.closure_tag || tag = Obj.infix_tag ->
+    Can_be_taken
+  | Value_boxed_int _ when tag = Obj.custom_tag ->
+    Must_be_taken
+  | Value_block _ | Value_float _ | Value_set_of_closures _ | Value_closure _
+  | Value_string _ | Value_float_array _ | Value_boxed_int _ ->
+    Cannot_be_taken
+  | Value_bottom ->
+    Cannot_be_taken

diff --git a/middle_end/simple_value_approx.mli b/middle_end/simple_value_approx.mli
index bc1ce1217f3da530c1bf44352ef497f421f7d958..36501b053072cdca7cc0cbf5a3de6fad6b0ae2b1 100644 (file)
--- a/middle_end/simple_value_approx.mli
+++ b/middle_end/simple_value_approx.mli
@@ -30,15 +30,6 @@ type value_string = {
   size : int;
 }
 
-type value_float_array_contents =
-  | Contents of float option array
-  | Unknown_or_mutable
-
-type value_float_array = {
-  contents : value_float_array_contents;
-  size : int;
-}
-
 type unknown_because_of =
   | Unresolved_symbol of Symbol.t
   | Other
@@ -130,7 +121,7 @@ and descr = private
   | Value_int of int
   | Value_char of char
   | Value_constptr of int
-  | Value_float of float
+  | Value_float of float option
   | Value_boxed_int : 'a boxed_int * 'a -> descr
   | Value_set_of_closures of value_set_of_closures
   | Value_closure of value_closure
@@ -162,6 +153,15 @@ and value_set_of_closures = private {
   direct_call_surrogates : Closure_id.t Closure_id.Map.t;
 }
 
+and value_float_array_contents =
+  | Contents of t array
+  | Unknown_or_mutable
+
+and value_float_array = {
+  contents : value_float_array_contents;
+  size : int;
+}
+
 (** Extraction of the description of approximation(s). *)
 val descr : t -> descr
 val descrs : t list -> descr list
@@ -193,8 +193,9 @@ val value_unknown : unknown_because_of -> t
 val value_int : int -> t
 val value_char : char -> t
 val value_float : float -> t
+val value_any_float : t
 val value_mutable_float_array : size:int -> t
-val value_immutable_float_array : float option array -> t
+val value_immutable_float_array : t array -> t
 val value_string : int -> string option -> t
 val value_boxed_int : 'i boxed_int -> 'i -> t
 val value_constptr : int -> t
@@ -255,11 +256,17 @@ val augment_with_symbol_field : t -> Symbol.t -> int -> t
 (** Replace the description within an approximation. *)
 val replace_description : t -> descr -> t
 
+(** Improve the description by taking the kind into account *)
+val augment_with_kind : t -> Lambda.value_kind -> t
+
+(** Improve the kind by taking the description into account *)
+val augment_kind_with_approx : t -> Lambda.value_kind -> Lambda.value_kind
+
 val equal_boxed_int : 'a boxed_int -> 'a -> 'b boxed_int -> 'b -> bool
 
 (* CR-soon mshinwell for pchambart: Add comment describing semantics.  (Maybe
    we should move the comment from the .ml file into here.) *)
-val meet : t -> t -> t
+val meet : really_import_approx:(t -> t) -> t -> t -> t
 
 (** An approximation is "known" iff it is not [Value_unknown]. *)
 val known : t -> bool
@@ -399,3 +406,18 @@ val check_approx_for_closure_allowing_unresolved
 
 (** Returns the value if it can be proved to be a constant float *)
 val check_approx_for_float : t -> float option
+
+(** Returns the value if it can be proved to be a constant float array *)
+val float_array_as_constant : value_float_array -> float list option
+
+(** Returns the value if it can be proved to be a constant string *)
+val check_approx_for_string : t -> string option
+
+type switch_branch_selection =
+  | Cannot_be_taken
+  | Can_be_taken
+  | Must_be_taken
+
+(** Check that the branch is compatible with the approximation *)
+val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection
+val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection

diff --git a/middle_end/simplify_boxed_integer_ops.ml b/middle_end/simplify_boxed_integer_ops.ml
index 336cc16b52aa9aa2c5ae2547b8e49e169033654a..8fdc045de5a4792c7b344242851ac93a56af2fe5 100644 (file)
--- a/middle_end/simplify_boxed_integer_ops.ml
+++ b/middle_end/simplify_boxed_integer_ops.ml
@@ -67,8 +67,8 @@ end) : Simplify_boxed_integer_ops_intf.S with type t := I.t = struct
     | Paddbint kind when kind = I.kind -> eval I.add
     | Psubbint kind when kind = I.kind -> eval I.sub
     | Pmulbint kind when kind = I.kind -> eval I.mul
-    | Pdivbint kind when kind = I.kind && non_zero n2 -> eval I.div
-    | Pmodbint kind when kind = I.kind && non_zero n2 -> eval I.rem
+    | Pdivbint {size=kind} when kind = I.kind && non_zero n2 -> eval I.div
+    | Pmodbint {size=kind} when kind = I.kind && non_zero n2 -> eval I.rem
     | Pandbint kind when kind = I.kind -> eval I.logand
     | Porbint kind when kind = I.kind -> eval I.logor
     | Pxorbint kind when kind = I.kind -> eval I.logxor

diff --git a/middle_end/simplify_primitives.ml b/middle_end/simplify_primitives.ml
index c6ec4ad0577fe3a816924ed0350db9c20362886e..14c43efe379c5b0e6ad7c482a8ef31990a4b24a7 100644 (file)
--- a/middle_end/simplify_primitives.ml
+++ b/middle_end/simplify_primitives.ml
@@ -41,9 +41,16 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
       ~big_endian : Flambda.named * A.t * Inlining_cost.Benefit.t =
   let fpc = !Clflags.float_const_prop in
   match p with
-  | Pmakeblock(tag, Asttypes.Immutable) ->
-    let tag = Tag.create_exn tag in
-    expr, A.value_block tag (Array.of_list approxs), C.Benefit.zero
+  | Pmakeblock(tag_int, Asttypes.Immutable, shape) ->
+    let tag = Tag.create_exn tag_int in
+    let shape = match shape with
+      | None -> List.map (fun _ -> Lambda.Pgenval) args
+      | Some shape -> shape
+    in
+    let approxs = List.map2 A.augment_with_kind approxs shape in
+    let shape = List.map2 A.augment_kind_with_approx approxs shape in
+    Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape), args, dbg),
+    A.value_block tag (Array.of_list approxs), C.Benefit.zero
   | Praise _ ->
     expr, A.value_bottom, C.Benefit.zero
   | Pignore -> begin
@@ -59,12 +66,13 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
       expr, approx, C.Benefit.zero
   | Pmakearray (Pfloatarray, Immutable) ->
       let approx =
-        A.value_immutable_float_array
-          (Array.of_list (List.map A.check_approx_for_float approxs))
+        A.value_immutable_float_array (Array.of_list approxs)
       in
       expr, approx, C.Benefit.zero
   | Pintcomp Ceq when phys_equal approxs ->
     S.const_bool_expr expr true
+  | Pintcomp Cneq when phys_equal approxs ->
+    S.const_bool_expr expr false
     (* N.B. Having [not (phys_equal approxs)] would not on its own tell us
        anything about whether the two values concerned are unequal.  To judge
        that, it would be necessary to prove that the approximations are
@@ -108,8 +116,8 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
       | Paddint -> S.const_int_expr expr (x + y)
       | Psubint -> S.const_int_expr expr (x - y)
       | Pmulint -> S.const_int_expr expr (x * y)
-      | Pdivint when y <> 0 -> S.const_int_expr expr (x / y)
-      | Pmodint when y <> 0 -> S.const_int_expr expr (x mod y)
+      | Pdivint _ when y <> 0 -> S.const_int_expr expr (x / y)
+      | Pmodint _ when y <> 0 -> S.const_int_expr expr (x mod y)
       | Pandint -> S.const_int_expr expr (x land y)
       | Porint -> S.const_int_expr expr (x lor y)
       | Pxorint -> S.const_int_expr expr (x lxor y)
@@ -118,7 +126,11 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
       | Pasrint when shift_precond -> S.const_int_expr expr (x asr y)
       | Pintcomp cmp -> S.const_comparison_expr expr cmp x y
       | Pisout -> S.const_bool_expr expr (y > x || y < 0)
-      (* [Psequand] and [Psequor] have special simplification rules, above. *)
+      | _ -> expr, A.value_unknown Other, C.Benefit.zero
+      end
+    | [Value_char x; Value_char y] ->
+      begin match p with
+      | Pintcomp cmp -> S.const_comparison_expr expr cmp x y
       | _ -> expr, A.value_unknown Other, C.Benefit.zero
       end
     | [Value_constptr x] ->
@@ -140,17 +152,19 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
         | Ostype_unix -> S.const_bool_expr expr (Sys.os_type = "Unix")
         | Ostype_win32 -> S.const_bool_expr expr (Sys.os_type = "Win32")
         | Ostype_cygwin -> S.const_bool_expr expr (Sys.os_type = "Cygwin")
+        | Backend_type ->
+          S.const_ptr_expr expr 0 (* tag 0 is the same as Native *)
         end
       | _ -> expr, A.value_unknown Other, C.Benefit.zero
       end
-    | [Value_float x] when fpc ->
+    | [Value_float (Some x)] when fpc ->
       begin match p with
       | Pintoffloat -> S.const_int_expr expr (int_of_float x)
       | Pnegfloat -> S.const_float_expr expr (-. x)
       | Pabsfloat -> S.const_float_expr expr (abs_float x)
       | _ -> expr, A.value_unknown Other, C.Benefit.zero
       end
-    | [Value_float n1; Value_float n2] when fpc ->
+    | [Value_float (Some n1); Value_float (Some n2)] when fpc ->
       begin match p with
       | Paddfloat -> S.const_float_expr expr (n1 +. n2)
       | Psubfloat -> S.const_float_expr expr (n1 -. n2)
@@ -183,13 +197,17 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
         ~size_int
     | [Value_block _] when p = Lambda.Pisint ->
       S.const_bool_expr expr false
-    | [Value_string { size }] when p = Lambda.Pstringlength ->
+    | [Value_string { size }]
+      when (p = Lambda.Pstringlength || p = Lambda.Pbyteslength) ->
       S.const_int_expr expr size
     | [Value_string { size; contents = Some s };
        (Value_int x | Value_constptr x)] when x >= 0 && x < size ->
         begin match p with
         | Pstringrefu
-        | Pstringrefs -> S.const_char_expr expr s.[x]
+        | Pstringrefs
+        | Pbytesrefu
+        | Pbytesrefs ->
+          S.const_char_expr (Prim(Pstringrefu, args, dbg)) s.[x]
         | _ -> expr, A.value_unknown Other, C.Benefit.zero
         end
     | [Value_string { size; contents = None };
@@ -199,14 +217,22 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
           A.value_unknown Other,
           (* we improved it, but there is no way to account for that: *)
           C.Benefit.zero
+    | [Value_string { size; contents = None };
+       (Value_int x | Value_constptr x)]
+      when x >= 0 && x < size && p = Lambda.Pbytesrefs ->
+        Flambda.Prim (Pbytesrefu, args, dbg),
+          A.value_unknown Other,
+          (* we improved it, but there is no way to account for that: *)
+          C.Benefit.zero
+
     | [Value_float_array { size; contents }] ->
         begin match p with
         | Parraylength _ -> S.const_int_expr expr size
         | Pfloatfield i ->
           begin match contents with
           | A.Contents a when i >= 0 && i < size ->
-            begin match a.(i) with
-            | None -> expr, A.value_unknown Other, C.Benefit.zero
+            begin match A.check_approx_for_float a.(i) with
+            | None -> expr, a.(i), C.Benefit.zero
             | Some v -> S.const_float_expr expr v
             end
           | Contents _ | Unknown_or_mutable ->
@@ -214,4 +240,9 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
           end
         | _ -> expr, A.value_unknown Other, C.Benefit.zero
         end
-    | _ -> expr, A.value_unknown Other, C.Benefit.zero
+    | _ ->
+      match Semantics_of_primitives.return_type_of_primitive p with
+      | Float ->
+        expr, A.value_any_float, C.Benefit.zero
+      | Other ->
+        expr, A.value_unknown Other, C.Benefit.zero

diff --git a/middle_end/unbox_specialised_args.ml b/middle_end/unbox_specialised_args.ml
old mode 100644 (file)
new mode 100755 (executable)
index ced1636..32ce408
--- a/middle_end/unbox_specialised_args.ml
+++ b/middle_end/unbox_specialised_args.ml
@@ -63,7 +63,7 @@ module Transform = struct
                 (* If for function [f] we would extract a projection expression
                    [e] from some specialised argument [x] of [f], and we know
                    from [Invariant_params] that a specialised argument [y] of
-                   another function [g] flows to [x], we will add add [e] with
+                   another function [g] flows to [x], we will add [e] with
                    [y] substituted for [x] throughout as a newly-specialised
                    argument for [g].  This should help reduce the number of
                    simplification rounds required for mutually-recursive

diff --git a/ocamldoc/.depend b/ocamldoc/.depend
index c66b0750de870d6fbbcf3c2cec0fa3cbde8b44ac..9aaef1f9ef27a351c55e9c2c3696b0d986711735 100644 (file)
--- a/ocamldoc/.depend
+++ b/ocamldoc/.depend
@@ -1,27 +1,26 @@
-odoc.cmo : ../typing/typedtree.cmi odoc_messages.cmo odoc_info.cmi \
-    odoc_global.cmi odoc_gen.cmi odoc_config.cmi odoc_args.cmi \
-    odoc_analyse.cmi ../utils/misc.cmi ../utils/config.cmi \
-    ../utils/clflags.cmi
-odoc.cmx : ../typing/typedtree.cmx odoc_messages.cmx odoc_info.cmx \
-    odoc_global.cmx odoc_gen.cmx odoc_config.cmx odoc_args.cmx \
-    odoc_analyse.cmx ../utils/misc.cmx ../utils/config.cmx \
-    ../utils/clflags.cmx
+odoc.cmo : odoc_messages.cmo odoc_info.cmi odoc_global.cmi odoc_gen.cmi \
+    odoc_config.cmi odoc_args.cmi odoc_analyse.cmi
+odoc.cmx : odoc_messages.cmx odoc_info.cmx odoc_global.cmx odoc_gen.cmx \
+    odoc_config.cmx odoc_args.cmx odoc_analyse.cmx
 odoc_analyse.cmo : ../utils/warnings.cmi ../typing/types.cmi \
     ../typing/typemod.cmi ../typing/typedtree.cmi ../parsing/syntaxerr.cmi \
     ../driver/pparse.cmi ../parsing/parse.cmi odoc_types.cmi odoc_text.cmi \
     odoc_sig.cmi odoc_module.cmo odoc_misc.cmi odoc_messages.cmo \
     odoc_merge.cmi odoc_global.cmi odoc_dep.cmo odoc_cross.cmi \
     odoc_comments.cmi odoc_class.cmo odoc_ast.cmi ../utils/misc.cmi \
-    ../parsing/location.cmi ../parsing/lexer.cmi ../typing/env.cmi \
-    ../utils/config.cmi ../utils/clflags.cmi odoc_analyse.cmi
+    ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
+    ../typing/env.cmi ../utils/config.cmi ../utils/clflags.cmi \
+    ../parsing/asttypes.cmi odoc_analyse.cmi
 odoc_analyse.cmx : ../utils/warnings.cmx ../typing/types.cmx \
     ../typing/typemod.cmx ../typing/typedtree.cmx ../parsing/syntaxerr.cmx \
     ../driver/pparse.cmx ../parsing/parse.cmx odoc_types.cmx odoc_text.cmx \
     odoc_sig.cmx odoc_module.cmx odoc_misc.cmx odoc_messages.cmx \
     odoc_merge.cmx odoc_global.cmx odoc_dep.cmx odoc_cross.cmx \
     odoc_comments.cmx odoc_class.cmx odoc_ast.cmx ../utils/misc.cmx \
-    ../parsing/location.cmx ../parsing/lexer.cmx ../typing/env.cmx \
-    ../utils/config.cmx ../utils/clflags.cmx odoc_analyse.cmi
+    ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
+    ../typing/env.cmx ../utils/config.cmx ../utils/clflags.cmx \
+    ../parsing/asttypes.cmi odoc_analyse.cmi
+odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi
 odoc_args.cmo : ../utils/warnings.cmi odoc_types.cmi odoc_texi.cmo \
     odoc_messages.cmo odoc_man.cmo odoc_latex.cmo odoc_html.cmo \
     odoc_global.cmi odoc_gen.cmi odoc_dot.cmo odoc_config.cmi \
@@ -34,20 +33,23 @@ odoc_args.cmx : ../utils/warnings.cmx odoc_types.cmx odoc_texi.cmx \
     ../utils/misc.cmx ../driver/main_args.cmx ../parsing/location.cmx \
     ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx \
     odoc_args.cmi
+odoc_args.cmi : odoc_gen.cmi
 odoc_ast.cmo : ../typing/types.cmi ../typing/typedtree.cmi \
     ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \
     odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \
-    odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \
-    odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_env.cmi \
-    odoc_class.cmo ../utils/misc.cmi ../parsing/location.cmi \
-    ../typing/ident.cmi ../parsing/asttypes.cmi odoc_ast.cmi
+    odoc_parameter.cmo odoc_module.cmo odoc_messages.cmo odoc_global.cmi \
+    odoc_extension.cmo odoc_exception.cmo odoc_env.cmi odoc_class.cmo \
+    ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \
+    ../parsing/asttypes.cmi odoc_ast.cmi
 odoc_ast.cmx : ../typing/types.cmx ../typing/typedtree.cmx \
     ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \
     odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \
-    odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \
-    odoc_global.cmx odoc_extension.cmx odoc_exception.cmx odoc_env.cmx \
-    odoc_class.cmx ../utils/misc.cmx ../parsing/location.cmx \
-    ../typing/ident.cmx ../parsing/asttypes.cmi odoc_ast.cmi
+    odoc_parameter.cmx odoc_module.cmx odoc_messages.cmx odoc_global.cmx \
+    odoc_extension.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \
+    ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \
+    ../parsing/asttypes.cmi odoc_ast.cmi
+odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \
+    ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo
 odoc_class.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
     odoc_parameter.cmo odoc_name.cmi
 odoc_class.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \
@@ -60,10 +62,13 @@ odoc_comments.cmx : odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \
     odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx \
     odoc_lexer.cmx odoc_global.cmx odoc_cross.cmx odoc_comments_global.cmx \
     odoc_comments.cmi
+odoc_comments.cmi : odoc_types.cmi odoc_module.cmo
 odoc_comments_global.cmo : odoc_comments_global.cmi
 odoc_comments_global.cmx : odoc_comments_global.cmi
+odoc_comments_global.cmi :
 odoc_config.cmo : ../utils/config.cmi odoc_config.cmi
 odoc_config.cmx : ../utils/config.cmx odoc_config.cmi
+odoc_config.cmi :
 odoc_control.cmo :
 odoc_control.cmx :
 odoc_cross.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \
@@ -74,12 +79,14 @@ odoc_cross.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \
     odoc_scan.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \
     odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_extension.cmx \
     odoc_exception.cmx odoc_class.cmx odoc_cross.cmi
+odoc_cross.cmi : odoc_types.cmi odoc_module.cmo
 odoc_dag2html.cmo : odoc_info.cmi odoc_dag2html.cmi
 odoc_dag2html.cmx : odoc_info.cmx odoc_dag2html.cmi
+odoc_dag2html.cmi : odoc_info.cmi
 odoc_dep.cmo : ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \
-    odoc_module.cmo ../tools/depend.cmi
+    odoc_module.cmo ../parsing/depend.cmi
 odoc_dep.cmx : ../parsing/parsetree.cmi odoc_type.cmx odoc_print.cmx \
-    odoc_module.cmx ../tools/depend.cmx
+    odoc_module.cmx ../parsing/depend.cmx
 odoc_dot.cmo : odoc_messages.cmo odoc_info.cmi
 odoc_dot.cmx : odoc_messages.cmx odoc_info.cmx
 odoc_env.cmo : ../typing/types.cmi ../typing/printtyp.cmi \
@@ -88,6 +95,7 @@ odoc_env.cmo : ../typing/types.cmi ../typing/printtyp.cmi \
 odoc_env.cmx : ../typing/types.cmx ../typing/printtyp.cmx \
     ../typing/predef.cmx ../typing/path.cmx odoc_name.cmx ../utils/misc.cmx \
     ../typing/btype.cmx odoc_env.cmi
+odoc_env.cmi : ../typing/types.cmi odoc_name.cmi
 odoc_exception.cmo : ../typing/types.cmi odoc_types.cmi odoc_type.cmo \
     odoc_name.cmi
 odoc_exception.cmx : ../typing/types.cmx odoc_types.cmx odoc_type.cmx \
@@ -100,10 +108,13 @@ odoc_gen.cmo : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \
     odoc_html.cmo odoc_dot.cmo odoc_gen.cmi
 odoc_gen.cmx : odoc_texi.cmx odoc_module.cmx odoc_man.cmx odoc_latex.cmx \
     odoc_html.cmx odoc_dot.cmx odoc_gen.cmi
+odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \
+    odoc_html.cmo odoc_dot.cmo
 odoc_global.cmo : odoc_types.cmi odoc_messages.cmo odoc_config.cmi \
     ../utils/clflags.cmi odoc_global.cmi
 odoc_global.cmx : odoc_types.cmx odoc_messages.cmx odoc_config.cmx \
     ../utils/clflags.cmx odoc_global.cmi
+odoc_global.cmi : odoc_types.cmi
 odoc_html.cmo : odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \
     odoc_info.cmi odoc_global.cmi odoc_dag2html.cmi ../parsing/asttypes.cmi
 odoc_html.cmx : odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \
@@ -120,6 +131,10 @@ odoc_info.cmx : ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \
     odoc_misc.cmx odoc_global.cmx odoc_extension.cmx odoc_exception.cmx \
     odoc_dep.cmx odoc_config.cmx odoc_comments.cmx odoc_class.cmx \
     odoc_analyse.cmx ../parsing/location.cmx odoc_info.cmi
+odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
+    odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \
+    odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \
+    ../parsing/location.cmi ../parsing/asttypes.cmi
 odoc_inherit.cmo :
 odoc_inherit.cmx :
 odoc_latex.cmo : odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \
@@ -137,13 +152,12 @@ odoc_man.cmo : odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \
 odoc_man.cmx : odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \
     odoc_info.cmx ../utils/misc.cmx ../parsing/asttypes.cmi
 odoc_merge.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \
-    odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \
-    odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \
-    odoc_merge.cmi
+    odoc_parameter.cmo odoc_module.cmo odoc_messages.cmo odoc_global.cmi \
+    odoc_extension.cmo odoc_exception.cmo odoc_class.cmo odoc_merge.cmi
 odoc_merge.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \
-    odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \
-    odoc_global.cmx odoc_extension.cmx odoc_exception.cmx odoc_class.cmx \
-    odoc_merge.cmi
+    odoc_parameter.cmx odoc_module.cmx odoc_messages.cmx odoc_global.cmx \
+    odoc_extension.cmx odoc_exception.cmx odoc_class.cmx odoc_merge.cmi
+odoc_merge.cmi : odoc_types.cmi odoc_module.cmo
 odoc_messages.cmo : ../utils/config.cmi
 odoc_messages.cmx : ../utils/config.cmx
 odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \
@@ -152,6 +166,8 @@ odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \
 odoc_misc.cmx : ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \
     odoc_types.cmx odoc_messages.cmx ../parsing/longident.cmx \
     ../typing/ctype.cmx ../typing/btype.cmx odoc_misc.cmi
+odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi \
+    ../parsing/asttypes.cmi
 odoc_module.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
     odoc_type.cmo odoc_name.cmi odoc_extension.cmo odoc_exception.cmo \
     odoc_class.cmo
@@ -162,44 +178,51 @@ odoc_name.cmo : ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \
     odoc_name.cmi
 odoc_name.cmx : ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \
     odoc_name.cmi
+odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \
+    ../typing/ident.cmi
 odoc_ocamlhtml.cmo :
 odoc_ocamlhtml.cmx :
 odoc_parameter.cmo : ../typing/types.cmi odoc_types.cmi
 odoc_parameter.cmx : ../typing/types.cmx odoc_types.cmx
 odoc_parser.cmo : odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi
 odoc_parser.cmx : odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi
+odoc_parser.cmi : odoc_types.cmi
 odoc_print.cmo : ../typing/types.cmi ../typing/printtyp.cmi \
     ../utils/misc.cmi odoc_print.cmi
 odoc_print.cmx : ../typing/types.cmx ../typing/printtyp.cmx \
     ../utils/misc.cmx odoc_print.cmi
+odoc_print.cmi : ../typing/types.cmi
 odoc_scan.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \
     odoc_extension.cmo odoc_exception.cmo odoc_class.cmo
 odoc_scan.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \
     odoc_extension.cmx odoc_exception.cmx odoc_class.cmx
 odoc_search.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \
-    odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_extension.cmo \
-    odoc_exception.cmo odoc_class.cmo odoc_search.cmi
+    odoc_module.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \
+    odoc_search.cmi
 odoc_search.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \
-    odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_extension.cmx \
-    odoc_exception.cmx odoc_class.cmx odoc_search.cmi
+    odoc_module.cmx odoc_extension.cmx odoc_exception.cmx odoc_class.cmx \
+    odoc_search.cmi
+odoc_search.cmi : odoc_value.cmo odoc_types.cmi odoc_type.cmo \
+    odoc_module.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo
 odoc_see_lexer.cmo : odoc_parser.cmi
 odoc_see_lexer.cmx : odoc_parser.cmx
 odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \
-    ../typing/path.cmi ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi \
-    odoc_type.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \
-    odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \
-    odoc_extension.cmo odoc_exception.cmo odoc_env.cmi odoc_class.cmo \
-    ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \
-    ../typing/ctype.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \
-    odoc_sig.cmi
+    ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \
+    odoc_parameter.cmo odoc_module.cmo odoc_misc.cmi odoc_messages.cmo \
+    odoc_merge.cmi odoc_global.cmi odoc_extension.cmo odoc_exception.cmo \
+    odoc_env.cmi odoc_class.cmo ../utils/misc.cmi ../parsing/location.cmi \
+    ../typing/ident.cmi ../typing/ctype.cmi ../typing/btype.cmi \
+    ../parsing/asttypes.cmi odoc_sig.cmi
 odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \
-    ../typing/path.cmx ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx \
-    odoc_type.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \
-    odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \
-    odoc_extension.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \
-    ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \
-    ../typing/ctype.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \
-    odoc_sig.cmi
+    ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \
+    odoc_parameter.cmx odoc_module.cmx odoc_misc.cmx odoc_messages.cmx \
+    odoc_merge.cmx odoc_global.cmx odoc_extension.cmx odoc_exception.cmx \
+    odoc_env.cmx odoc_class.cmx ../utils/misc.cmx ../parsing/location.cmx \
+    ../typing/ident.cmx ../typing/ctype.cmx ../typing/btype.cmx \
+    ../parsing/asttypes.cmi odoc_sig.cmi
+odoc_sig.cmi : ../typing/types.cmi ../typing/typedtree.cmi \
+    ../parsing/parsetree.cmi odoc_types.cmi odoc_type.cmo odoc_name.cmi \
+    odoc_module.cmo odoc_env.cmi odoc_class.cmo
 odoc_str.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \
     odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \
     odoc_messages.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \
@@ -208,6 +231,8 @@ odoc_str.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \
     odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \
     odoc_messages.cmx odoc_extension.cmx odoc_exception.cmx odoc_class.cmx \
     ../parsing/asttypes.cmi odoc_str.cmi
+odoc_str.cmi : ../typing/types.cmi odoc_value.cmo odoc_type.cmo \
+    odoc_extension.cmo odoc_exception.cmo odoc_class.cmo
 odoc_test.cmo : odoc_info.cmi odoc_gen.cmi odoc_args.cmi
 odoc_test.cmx : odoc_info.cmx odoc_gen.cmx odoc_args.cmx
 odoc_texi.cmo : ../typing/types.cmi odoc_to_text.cmo odoc_messages.cmo \
@@ -218,52 +243,24 @@ odoc_text.cmo : odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \
     odoc_text.cmi
 odoc_text.cmx : odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \
     odoc_text.cmi
+odoc_text.cmi : odoc_types.cmi
 odoc_text_lexer.cmo : odoc_text_parser.cmi odoc_misc.cmi
 odoc_text_lexer.cmx : odoc_text_parser.cmx odoc_misc.cmx
 odoc_text_parser.cmo : odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi
 odoc_text_parser.cmx : odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi
-odoc_to_text.cmo : odoc_module.cmo odoc_messages.cmo odoc_info.cmi
-odoc_to_text.cmx : odoc_module.cmx odoc_messages.cmx odoc_info.cmx
+odoc_text_parser.cmi : odoc_types.cmi
+odoc_to_text.cmo : odoc_str.cmi odoc_module.cmo odoc_messages.cmo \
+    odoc_info.cmi
+odoc_to_text.cmx : odoc_str.cmx odoc_module.cmx odoc_messages.cmx \
+    odoc_info.cmx
 odoc_type.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi \
     ../parsing/asttypes.cmi
 odoc_type.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx \
     ../parsing/asttypes.cmi
 odoc_types.cmo : odoc_messages.cmo ../parsing/location.cmi odoc_types.cmi
 odoc_types.cmx : odoc_messages.cmx ../parsing/location.cmx odoc_types.cmi
+odoc_types.cmi : ../parsing/location.cmi
 odoc_value.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \
     odoc_parameter.cmo odoc_name.cmi odoc_misc.cmi ../parsing/asttypes.cmi
 odoc_value.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \
     odoc_parameter.cmx odoc_name.cmx odoc_misc.cmx ../parsing/asttypes.cmi
-odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi
-odoc_args.cmi : odoc_gen.cmi
-odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \
-    ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo
-odoc_comments.cmi : odoc_types.cmi odoc_module.cmo
-odoc_comments_global.cmi :
-odoc_config.cmi :
-odoc_cross.cmi : odoc_types.cmi odoc_module.cmo
-odoc_dag2html.cmi : odoc_info.cmi
-odoc_env.cmi : ../typing/types.cmi odoc_name.cmi
-odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \
-    odoc_html.cmo odoc_dot.cmo
-odoc_global.cmi : odoc_types.cmi
-odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
-    odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \
-    odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \
-    ../parsing/location.cmi ../parsing/asttypes.cmi
-odoc_merge.cmi : odoc_types.cmi odoc_module.cmo
-odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi \
-    ../parsing/asttypes.cmi
-odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \
-    ../typing/ident.cmi
-odoc_parser.cmi : odoc_types.cmi
-odoc_print.cmi : ../typing/types.cmi
-odoc_search.cmi : odoc_value.cmo odoc_types.cmi odoc_type.cmo \
-    odoc_module.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo
-odoc_sig.cmi : ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \
-    odoc_type.cmo odoc_name.cmi odoc_module.cmo odoc_env.cmi odoc_class.cmo
-odoc_str.cmi : ../typing/types.cmi odoc_value.cmo odoc_type.cmo \
-    odoc_extension.cmo odoc_exception.cmo odoc_class.cmo
-odoc_text.cmi : odoc_types.cmi
-odoc_text_parser.cmi : odoc_types.cmi
-odoc_types.cmi : ../parsing/location.cmi

diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile
index 2eba14c1c05ba20d88a61b7b533ba78fdab6cee9..7b53a036afb8a74b7a4acf69a46d455d3f2f1a9e 100644 (file)
--- a/ocamldoc/Makefile
+++ b/ocamldoc/Makefile
@@ -75,7 +75,6 @@ INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \
        -I $(OCAMLSRCDIR)/typing \
        -I $(OCAMLSRCDIR)/driver \
        -I $(OCAMLSRCDIR)/bytecomp \
-       -I $(OCAMLSRCDIR)/tools \
        -I $(OCAMLSRCDIR)/toplevel/
 
 INCLUDES_NODEP=        -I $(OCAMLSRCDIR)/stdlib \
@@ -87,7 +86,7 @@ INCLUDES_NODEP=       -I $(OCAMLSRCDIR)/stdlib \
 
 INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
 
-COMPFLAGS=$(INCLUDES) -warn-error A -safe-string
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A -safe-string -strict-sequence -strict-formats
 LINKFLAGS=$(INCLUDES) -nostdlib
 
 CMOFILES= odoc_config.cmo \
@@ -151,13 +150,6 @@ LIBCMOFILES=$(CMOFILES)
 LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx)
 LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi)
 
-# Les cmo et cmx de la distrib OCAML
-OCAMLCMOFILES= \
-       $(OCAMLSRCDIR)/tools/depend.cmo
-
-OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx)
-
-
 STDLIB_MLIS=../stdlib/*.mli \
   ../parsing/*.mli \
        ../otherlibs/$(UNIXLIB)/unix.mli \
@@ -190,17 +182,17 @@ debug:
 $(OCAMLDOC): $(EXECMOFILES)
        $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \
                  $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \
-                 $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES)
+                 $(LINKFLAGS) $(EXECMOFILES)
 $(OCAMLDOC_OPT): $(EXECMXFILES)
        $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \
                    $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \
-                   $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES)
+                   $(LINKFLAGS) $(EXECMXFILES)
 
 $(OCAMLDOC_LIBCMA): $(LIBCMOFILES)
-       $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo \
+       $(OCAMLC) -a -o $@ $(LINKFLAGS) \
                  $(LIBCMOFILES)
 $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES)
-       $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx \
+       $(OCAMLOPT) -a -o $@ $(LINKFLAGS) \
                    $(LIBCMXFILES)
 
 manpages: stdlib_man/Pervasives.3o

diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt
index 6a993e32651aeb51bd33cf8fdde11a67d1c87e84..7bb17e25b9c5a4a6276a55f95d27672a4cc9ea24 100644 (file)
--- a/ocamldoc/Makefile.nt
+++ b/ocamldoc/Makefile.nt
@@ -61,7 +61,6 @@ INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \
        -I $(OCAMLSRCDIR)/typing \
        -I $(OCAMLSRCDIR)/driver \
        -I $(OCAMLSRCDIR)/bytecomp \
-       -I $(OCAMLSRCDIR)/tools \
        -I $(OCAMLSRCDIR)/toplevel/
 
 INCLUDES_NODEP=        -I $(OCAMLSRCDIR)/stdlib \
@@ -73,7 +72,7 @@ INCLUDES_NODEP=       -I $(OCAMLSRCDIR)/stdlib \
 
 INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
 
-COMPFLAGS=$(INCLUDES) -warn-error A -safe-string
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A -safe-string -strict-sequence -strict-formats
 LINKFLAGS=$(INCLUDES) -nostdlib
 
 CMOFILES= odoc_config.cmo \
@@ -137,12 +136,6 @@ LIBCMOFILES=$(CMOFILES)
 LIBCMXFILES= $(LIBCMOFILES:.cmo=.cmx)
 LIBCMIFILES= $(LIBCMOFILES:.cmo=.cmi)
 
-# Les cmo et cmx de la distrib OCAML
-OCAMLCMOFILES= \
-       $(OCAMLSRCDIR)/tools/depend.cmo
-
-OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx)
-
 all:
        $(MAKEREC) exe
        $(MAKEREC) lib
@@ -160,17 +153,17 @@ debug:
 $(OCAMLDOC): $(EXECMOFILES)
        $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \
                  $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \
-                 $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES)
+                 $(LINKFLAGS) $(EXECMOFILES)
 $(OCAMLDOC_OPT): $(EXECMXFILES)
        $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \
                    $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \
-                   $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES)
+                   $(LINKFLAGS) $(EXECMXFILES)
 
 $(OCAMLDOC_LIBCMA): $(LIBCMOFILES)
-       $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo \
+       $(OCAMLC) -a -o $@ $(LINKFLAGS) \
                  $(LIBCMOFILES)
 $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES)
-       $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx \
+       $(OCAMLOPT) -a -o $@ $(LINKFLAGS) \
                    $(LIBCMXFILES)
 
 # Parsers and lexers dependencies :
@@ -256,7 +249,7 @@ depend::
        $(OCAMLLEX) odoc_lexer.mll
        $(OCAMLLEX) odoc_ocamlhtml.mll
        $(OCAMLLEX) odoc_see_lexer.mll
-       $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend
+       $(OCAMLDEP) -slash $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend
 
 dummy:
 

diff --git a/ocamldoc/generators/odoc_literate.ml b/ocamldoc/generators/odoc_literate.ml
index da71b9ef6b2c98e6d2708c0759f2f1ddf4a3b57e..aec198081a01e5d3ffd6cb9c3a79d59e654a1465 100644 (file)
--- a/ocamldoc/generators/odoc_literate.ml
+++ b/ocamldoc/generators/odoc_literate.ml
@@ -16,7 +16,6 @@
 open Odoc_info
 module Naming = Odoc_html.Naming
 open Odoc_info.Value
-open Odoc_info.Module
 
 let p = Printf.bprintf
 let bp = Printf.bprintf
@@ -38,20 +37,20 @@ module Generator =
 struct
 class html =
   object (self)
-    inherit Html.html as html
+    inherit Html.html
 
-    method private html_of_module_comment b text =
+    method! private html_of_module_comment b text =
       let br1, br2 =
         match text with
-          [(Odoc_info.Title (n, l_opt, t))] -> false, false
-        | (Odoc_info.Title (n, l_opt, t)) :: _ -> false, true
+          [(Odoc_info.Title _)] -> false, false
+        | (Odoc_info.Title _) :: _ -> false, true
         | _ -> true, true
       in
       if br1 then p b "<br/>";
       self#html_of_text b text;
       if br2 then p b "<br/><br/>\n"
 
-    method private html_of_Title b n l_opt t =
+    method! private html_of_Title b n l_opt t =
       let label1 = self#create_title_label (n, l_opt, t) in
       p b "<a name=\"%s\"></a>\n" (Naming.label_target label1);
       p b "<h%d>" n;
@@ -75,7 +74,7 @@ class html =
       Printf.bprintf b "</div>"
 
     (** Print html code for a value. *)
-    method private html_of_value b v =
+    method! private html_of_value b v =
       Odoc_info.reset_type_names ();
       self#html_of_info b v.val_info;
       bs b "<pre>";

diff --git a/ocamldoc/generators/odoc_todo.ml b/ocamldoc/generators/odoc_todo.ml
index 01d3d94a75cb985d8d3450ac6c628d6270414fe9..d404e9b0f59e25ae72e48dd37f5718e152169c12 100644 (file)
--- a/ocamldoc/generators/odoc_todo.ml
+++ b/ocamldoc/generators/odoc_todo.ml
@@ -107,44 +107,44 @@ struct
                 l;
               p b "</div>"
 
-    method scan_value v =
+    method! scan_value v =
       self#gen_if_tag
         v.val_name
         (Odoc_html.Naming.complete_value_target v)
         v.val_info
 
-    method scan_type t =
+    method! scan_type t =
       self#gen_if_tag
         t.ty_name
         (Odoc_html.Naming.complete_type_target t)
         t.ty_info
 
-    method scan_extension_constructor x =
+    method! scan_extension_constructor x =
       self#gen_if_tag
         x.xt_name
         (Odoc_html.Naming.complete_extension_target x)
         x.xt_type_extension.te_info
 
-    method scan_exception e =
+    method! scan_exception e =
       self#gen_if_tag
         e.ex_name
         (Odoc_html.Naming.complete_exception_target e)
         e.ex_info
 
-    method scan_attribute a =
+    method! scan_attribute a =
       self#gen_if_tag
         a.att_value.val_name
         (Odoc_html.Naming.complete_attribute_target a)
         a.att_value.val_info
 
-    method scan_method m =
+    method! scan_method m =
       self#gen_if_tag
         m.met_value.val_name
         (Odoc_html.Naming.complete_method_target m)
         m.met_value.val_info
 
    (** This method scan the elements of the given module. *)
-    method scan_module_elements m =
+    method! scan_module_elements m =
       List.iter
         (fun ele ->
           match ele with
@@ -161,30 +161,30 @@ struct
         )
         (Odoc_module.module_elements ~trans: false m)
 
-    method scan_included_module _ = ()
+    method! scan_included_module _ = ()
 
-    method scan_class_pre c =
+    method! scan_class_pre c =
       self#gen_if_tag
         c.cl_name
         (fst (Odoc_html.Naming.html_files c.cl_name))
         c.cl_info;
       true
 
-    method scan_class_type_pre ct =
+    method! scan_class_type_pre ct =
       self#gen_if_tag
         ct.clt_name
         (fst (Odoc_html.Naming.html_files ct.clt_name))
         ct.clt_info;
       true
 
-    method scan_module_pre m =
+    method! scan_module_pre m =
       self#gen_if_tag
         m.m_name
         (fst (Odoc_html.Naming.html_files m.m_name))
         m.m_info;
       true
 
-    method scan_module_type_pre mt =
+    method! scan_module_type_pre mt =
       self#gen_if_tag
         mt.mt_name
         (fst (Odoc_html.Naming.html_files mt.mt_name))
@@ -202,7 +202,7 @@ struct
              html generator class *)
       val mutable scanner = new scanner (new Html.html )
 
-      method generate modules =
+      method! generate modules =
       (* prevent having the 'todo' tag signaled as not handled *)
       tag_functions <-  ("todo", (fun _ -> "")) :: tag_functions;
       (* generate doc as usual *)

diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva
index 2bbddc06703723a3baf37d08842900151a6ce4db..cd5bce0f6b9784034ccd48dde5950e78366768fa 100644 (file)
--- a/ocamldoc/ocamldoc.hva
+++ b/ocamldoc/ocamldoc.hva
@@ -20,7 +20,7 @@
 \newcommand\textbar{|}
 \newcommand\textbackslash{\begin{rawhtml}\\end{rawhtml}}
 \newcommand\textasciicircum{\^{}}
-\newcommand\sharp{#}
+\newcommand\hash{#}
 
 \let\ocamldocvspace\vspace
 \newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist}

diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml
index 45c3847a6476095ebaa6ee78fb37d5efd7349640..b49aa1b1179281ee07c3b18c4be614b6c8e4f198 100644 (file)
--- a/ocamldoc/odoc.ml
+++ b/ocamldoc/odoc.ml
@@ -16,12 +16,6 @@
 (** Main module for bytecode.
 @todo todo*)
 
-open Config
-open Clflags
-open Misc
-open Format
-open Typedtree
-
 module M = Odoc_messages
 
 let print_DEBUG s = print_string s ; print_newline ()

diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml
index c0b88bee3f2560c15e4c80c663b145cc2b68ced1..a166cd9b4d2898f258d1d4473f4a4bf6150d1de5 100644 (file)
--- a/ocamldoc/odoc_analyse.ml
+++ b/ocamldoc/odoc_analyse.ml
@@ -18,9 +18,6 @@
 
 let print_DEBUG s = print_string s ; print_newline ()
 
-open Config
-open Clflags
-open Misc
 open Format
 open Typedtree
 
@@ -30,7 +27,7 @@ open Typedtree
    then the directories specified with the -I option (in command-line order),
    then the standard library directory. *)
 let init_path () =
-  load_path :=
+  Config.load_path :=
     "" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
   Env.reset_cache ()
 
@@ -40,11 +37,24 @@ let initial_env () =
     if !Clflags.unsafe_string then Env.initial_unsafe_string
     else Env.initial_safe_string
   in
-  try
-    if !Clflags.nopervasives then initial else
-    Env.open_pers_signature "Pervasives" initial
-  with Not_found ->
-    fatal_error "cannot open pervasives.cmi"
+  let initial =
+    (* Open the Pervasives module by reading directly the corresponding cmi
+       file to avoid troubles when building the documentation for the
+       Pervasives modules.
+       Another option might be to add a -nopervasives option to ocamldoc and update
+       stdlib documentation's build process. *)
+    try
+      Env.open_pers_signature "Pervasives" initial
+    with Not_found ->
+      Misc.fatal_error @@ Printf.sprintf "cannot open pervasives.cmi" in
+  let open_mod env m =
+    let open Asttypes in
+    let lid = {loc = Location.in_file "ocamldoc command line";
+               txt = Longident.Lident m } in
+    snd (Typemod.type_open_ Override env lid.loc lid) in
+  (* Open the list of modules given as arguments of the "-open" flag
+     The list is reversed to open the modules in the left-to-right order *)
+  List.fold_left open_mod initial (List.rev !Clflags.open_modules)
 
 (** Optionally preprocess a source file *)
 let preprocess sourcefile =
@@ -55,8 +65,6 @@ let preprocess sourcefile =
       Pparse.report_error err;
     exit 2
 
-let (++) x f = f x
-
 (** Analysis of an implementation file. Returns (Some typedtree) if
    no error occured, else None and an error message is printed.*)
 
@@ -69,7 +77,7 @@ let no_docstring f x =
   Lexer.handle_docstrings := true;
   result
 
-let process_implementation_file ppf sourcefile =
+let process_implementation_file sourcefile =
   init_path ();
   let prefixname = Filename.chop_extension sourcefile in
   let modulename = String.capitalize_ascii(Filename.basename prefixname) in
@@ -79,7 +87,7 @@ let process_implementation_file ppf sourcefile =
   try
     let parsetree =
       Pparse.file ~tool_name Format.err_formatter inputfile
-        (no_docstring Parse.implementation) ast_impl_magic_number
+        (no_docstring Parse.implementation) Pparse.Structure
     in
     let typedtree =
       Typemod.type_implementation
@@ -102,7 +110,7 @@ let process_implementation_file ppf sourcefile =
 
 (** Analysis of an interface file. Returns (Some signature) if
    no error occured, else None and an error message is printed.*)
-let process_interface_file ppf sourcefile =
+let process_interface_file sourcefile =
   init_path ();
   let prefixname = Filename.chop_extension sourcefile in
   let modulename = String.capitalize_ascii(Filename.basename prefixname) in
@@ -110,9 +118,9 @@ let process_interface_file ppf sourcefile =
   let inputfile = preprocess sourcefile in
   let ast =
     Pparse.file ~tool_name Format.err_formatter inputfile
-      (no_docstring Parse.interface) ast_intf_magic_number
+      (no_docstring Parse.interface) Pparse.Signature
   in
-  let sg = Typemod.type_interface (initial_env()) ast in
+  let sg = Typemod.type_interface sourcefile (initial_env()) ast in
   Warnings.check_fatal ();
   (ast, sg, inputfile)
 
@@ -134,7 +142,7 @@ let process_error exn =
         (Printexc.to_string exn)
 
 (** Process the given file, according to its extension. Return the Module.t created, if any.*)
-let process_file ppf sourcefile =
+let process_file sourcefile =
   if !Odoc_global.verbose then
     (
      let f = match sourcefile with
@@ -150,7 +158,7 @@ let process_file ppf sourcefile =
       (
        Location.input_name := file;
        try
-         let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in
+         let (parsetree_typedtree_opt, input_file) = process_implementation_file file in
          match parsetree_typedtree_opt with
            None ->
              None
@@ -182,7 +190,7 @@ let process_file ppf sourcefile =
       (
        Location.input_name := file;
        try
-         let (ast, signat, input_file) = process_interface_file ppf file in
+         let (ast, signat, input_file) = process_interface_file file in
          let file_module = Sig_analyser.analyse_signature file
              !Location.input_name ast signat.sig_type
          in
@@ -394,7 +402,7 @@ let analyse_files ?(init=[]) files =
     (List.fold_left
        (fun acc -> fun file ->
          try
-           match process_file Format.err_formatter file with
+           match process_file file with
              None ->
                acc
            | Some m ->

diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml
index f2d7862e1c51807bfa48936eef1a3898407bdfcd..039c8d700040ac53c952bb80244eeae0e04f42aa 100644 (file)
--- a/ocamldoc/odoc_args.ml
+++ b/ocamldoc/odoc_args.ml
@@ -222,6 +222,8 @@ module Options = Main_args.Make_ocamldoc_options(struct
   let _no_strict_formats = unset Clflags.strict_formats
   let _thread = set Clflags.use_threads
   let _vmthread = set Clflags.use_vmthreads
+  let _unboxed_types = set Clflags.unboxed_types
+  let _no_unboxed_types = unset Clflags.unboxed_types
   let _unsafe () = assert false
   let _unsafe_string = set Clflags.unsafe_string
   let _v () = Compenv.print_version_and_library "documentation generator"
@@ -306,8 +308,8 @@ let default_options = Options.list @
     M.generate_dot ;
   "-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0),
   M.display_custom_generators_dir ;
-  "-i", Arg.String (fun s -> ()), M.add_load_dir ;
-  "-g", Arg.String (fun s -> ()), M.load_file ^
+  "-i", Arg.String (fun _ -> ()), M.add_load_dir ;
+  "-g", Arg.String (fun _ -> ()), M.load_file ^
   "\n\n *** HTML options ***\n";
 
 (* html only options *)

diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index d58176122b280897b8f6c8ef95c82f53481ec2ee..d987485c9d012f32995a77a8778280728bdc222c 100644 (file)
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -24,7 +24,6 @@ let print_DEBUG s = print_string s ; print_newline ();;
 
 type typedtree = (Typedtree.structure * Typedtree.module_coercion)
 
-module Name = Odoc_name
 open Odoc_parameter
 open Odoc_value
 open Odoc_type
@@ -34,12 +33,6 @@ open Odoc_class
 open Odoc_module
 open Odoc_types
 
-(** This variable contains the regular expression representing a blank.*)
-let blank = "[ \010\013\009\012']"
-
-(** This variable contains the regular expression representing a blank but not a '\n'.*)
-let simple_blank = "[ \013\009\012]"
-
 (** This module is used to search for structure items by name in a Typedtree.structure.
    One function creates two hash tables, which can then be used to search for elements.
    Class elements do not use tables.
@@ -55,7 +48,6 @@ module Typedtree_search =
       | X of string
       | E of string
       | P of string
-      | IM of string
 
     type tab = (ele, Typedtree.structure_item_desc) Hashtbl.t
     type tab_values = (Odoc_module.Name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t
@@ -100,7 +92,7 @@ module Typedtree_search =
             info_list
       | Typedtree.Tstr_class_type info_list ->
           List.iter
-            (fun ((id,id_loc,_) as ci) ->
+            (fun ((id,_,_) as ci) ->
               Hashtbl.add table
                 (CT (Name.from_ident id))
                 (Typedtree.Tstr_class_type [ci]))
@@ -192,10 +184,10 @@ module Typedtree_search =
       let rec iter = function
         | [] ->
             raise Not_found
-        | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_concrete (_, exp), _) } :: q
+        | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_concrete (_, exp), _) } :: _
           when Name.from_ident ident = name ->
             exp.Typedtree.exp_type
-        | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_virtual typ, _) } :: q
+        | { cf_desc = Typedtree.Tcf_val (_, _, ident, Tcfk_virtual typ, _) } :: _
           when Name.from_ident ident = name ->
             typ.Typedtree.ctyp_type
         | _ :: q ->
@@ -203,19 +195,11 @@ module Typedtree_search =
       in
       iter cls.Typedtree.cstr_fields
 
-    let class_sig_of_cltype_decl =
-      let rec iter = function
-        Types.Cty_constr (_, _, cty) -> iter cty
-      | Types.Cty_signature s -> s
-      | Types.Cty_arrow (_,_, cty) -> iter cty
-      in
-      fun ct_decl -> iter ct_decl.Types.clty_type
-
    let search_method_expression cls name =
       let rec iter = function
         | [] ->
             raise Not_found
-        | { cf_desc = Typedtree.Tcf_method (label, _, Tcfk_concrete (_, exp)) } :: q when label.txt = name ->
+        | { cf_desc = Typedtree.Tcf_method (label, _, Tcfk_concrete (_, exp)) } :: _ when label.txt = name ->
             exp
         | _ :: q ->
             iter q
@@ -304,7 +288,7 @@ module Analyser =
           (* This case means we have a 'function' without pattern, that's impossible *)
           raise (Failure "tt_analyse_function_parameters: 'function' without pattern")
 
-      | {c_lhs=pattern_param} :: second_ele :: q ->
+      | {c_lhs=pattern_param} :: _second_ele :: _ ->
           (* implicit pattern matching -> anonymous parameter and no more parameter *)
           (* FIXME : label ? *)
           let parameter = Odoc_parameter.Tuple ([], Odoc_env.subst_type env pattern_param.pat_type) in
@@ -358,7 +342,7 @@ module Analyser =
      let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag =
        let (pat, exp) = pat_exp in
        match (pat.pat_desc, exp.exp_desc) with
-         (Typedtree.Tpat_var (ident, _), Typedtree.Texp_function (_, pat_exp_list2, partial)) ->
+         (Typedtree.Tpat_var (ident, _), Typedtree.Texp_function (_, pat_exp_list2, _partial)) ->
            (* a new function is defined *)
            let name_pre = Name.from_ident ident in
            let name = Name.parens_if_infix name_pre in
@@ -407,7 +391,7 @@ module Analyser =
            in
            [ new_value ]
 
-       | (Typedtree.Tpat_tuple lpat, _) ->
+       | (Typedtree.Tpat_tuple _, _) ->
            (* new identifiers are defined *)
            (* FIXME : by now we don't accept to have global variables defined in tuples *)
            []
@@ -459,7 +443,7 @@ module Analyser =
                  [] ->
                    (* impossible case, it has already been filtered *)
                    assert false
-               | {c_lhs=pattern_param} :: second_ele :: q ->
+               | {c_lhs=pattern_param} :: _second_ele :: _ ->
                    (* implicit pattern matching -> anonymous parameter *)
                    (* Note : We can't match this pattern if it is the first call to the function. *)
                    let new_param = Simple_name
@@ -517,7 +501,7 @@ module Analyser =
 
     (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple
        (inherited classes, class elements). *)
-    let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls table =
+    let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls _table =
       let rec iter acc_inher acc_fields last_pos = function
         | [] ->
             let s = get_string_of_file last_pos pos_limit in
@@ -709,7 +693,7 @@ module Analyser =
              however they can be found in the class_type *)
           let params =
             match tt_class_exp.Typedtree.cl_type with
-              Types.Cty_constr (p2, type_exp_list, cltyp) ->
+              Types.Cty_constr (_p2, type_exp_list, _cltyp) ->
                 (* cltyp is the class type for [type_exp_list] p *)
                 type_exp_list
             | _ ->
@@ -743,8 +727,8 @@ module Analyser =
           ([],
            Class_structure (inherited_classes, class_elements) )
 
-      | (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2),
-         Typedtree.Tcl_fun (_, pat, ident_exp_list, tt_class_expr2, partial)) ->
+      | (Parsetree.Pcl_fun (_label, _expression_opt, _pattern, p_class_expr2),
+         Typedtree.Tcl_fun (_, pat, _ident_exp_list, tt_class_expr2, _partial)) ->
            (* we check that this is not an optional parameter with
               a default value. In this case, we look for the good parameter pattern *)
            let (parameter, next_tt_class_exp) =
@@ -829,7 +813,7 @@ module Analyser =
               env current_class_name comment_opt last_pos p_class_expr2
               tt_class_expr2 table
 
-      | (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2),
+      | (Parsetree.Pcl_constraint (p_class_expr2, _p_class_type2),
          Typedtree.Tcl_constraint (tt_class_expr2, _, _, _, _)) ->
           let (l, class_kind) = analyse_class_kind
               env current_class_name comment_opt last_pos p_class_expr2
@@ -1077,7 +1061,7 @@ module Analyser =
       iter env last_pos parsetree
 
    (** Analysis of a parse tree structure item to obtain a new environment and a list of elements.*)
-   and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc typedtree
+   and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc _typedtree
         table table_values =
       print_DEBUG "Odoc_ast:analyse_struture_item";
       match parsetree_item_desc with
@@ -1318,10 +1302,7 @@ module Analyser =
                       match tt_ext.ext_kind with
                           Text_decl(args, ret_type) ->
                           let xt_args =
-                            match args with
-                            | Cstr_tuple l -> Cstr_tuple (List.map (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) l)
-                            | Cstr_record _ -> assert false
-                          in
+                            Sig.get_cstr_args new_env ext_loc_end args in
                             {
                               xt_name = complete_name;
                               xt_args;
@@ -1379,10 +1360,7 @@ module Analyser =
                 let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
                 let loc_end =  loc.Location.loc_end.Lexing.pos_cnum in
                 let ex_args =
-                  match tt_args with
-                  | Cstr_tuple l -> Cstr_tuple (List.map (fun c -> Odoc_env.subst_type env c.ctyp_type) l)
-                  | Cstr_record l -> assert false (* TODO *)
-                in
+                  Sig.get_cstr_args env loc_end tt_args in
                 {
                   ex_name = complete_name ;
                   ex_info = comment_opt ;
@@ -1668,7 +1646,7 @@ module Analyser =
           in
           (0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_type_decl_list)
 
-      | Parsetree.Pstr_include incl ->
+      | Parsetree.Pstr_include _ ->
           (* we add a dummy included module which will be replaced by a correct
              one at the end of the module analysis,
              to use the Path.t of the included modules in the typdtree. *)
@@ -1716,8 +1694,8 @@ module Analyser =
       }
       in
       match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with
-        (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident (path, _))
-        | (Parsetree.Pmod_ident longident,
+        (Parsetree.Pmod_ident _, Typedtree.Tmod_ident (path, _))
+        | (Parsetree.Pmod_ident _,
            Typedtree.Tmod_constraint
              ({Typedtree.mod_desc = Typedtree.Tmod_ident (path, _)}, _, _, _))
           ->
@@ -1838,7 +1816,7 @@ module Analyser =
           }
 
       | (Parsetree.Pmod_unpack p_exp,
-         Typedtree.Tmod_unpack (t_exp, tt_modtype)) ->
+         Typedtree.Tmod_unpack (_t_exp, tt_modtype)) ->
           print_DEBUG ("Odoc_ast: case Parsetree.Pmod_unpack + Typedtree.Tmod_unpack "^module_name);
           let code =
             let loc = p_module_expr.Parsetree.pmod_loc in
@@ -1861,9 +1839,9 @@ module Analyser =
             m_kind = Module_unpack (code, alias) ;
           }
 
-      | (parsetree, typedtree) ->
+      | (_parsetree, _typedtree) ->
           (*DEBUG*)let s_parse =
-          (*DEBUG*)  match parsetree with
+          (*DEBUG*)  match _parsetree with
           (*DEBUG*)    Parsetree.Pmod_ident _ -> "Pmod_ident"
           (*DEBUG*)  | Parsetree.Pmod_structure _ -> "Pmod_structure"
           (*DEBUG*)  | Parsetree.Pmod_functor _ -> "Pmod_functor"
@@ -1873,7 +1851,7 @@ module Analyser =
           (*DEBUG*)  | Parsetree.Pmod_extension _ -> "Pmod_extension"
           (*DEBUG*)in
           (*DEBUG*)let s_typed =
-          (*DEBUG*)  match typedtree with
+          (*DEBUG*)  match _typedtree with
           (*DEBUG*)    Typedtree.Tmod_ident _ -> "Tmod_ident"
           (*DEBUG*)  | Typedtree.Tmod_structure _ -> "Tmod_structure"
           (*DEBUG*)  | Typedtree.Tmod_functor _ -> "Tmod_functor"

diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml
index 5f9ca827da40d7d0b384f6a6ce2dd8169069bd6b..168071a909cf0edf1ee1a844542f96ff5f632014 100644 (file)
--- a/ocamldoc/odoc_class.ml
+++ b/ocamldoc/odoc_class.ml
@@ -114,7 +114,7 @@ let rec class_elements ?(trans=true) cl =
   let rec iter_kind k =
     match k with
       Class_structure (_, elements) -> elements
-    | Class_constraint (c_kind, ct_kind) ->
+    | Class_constraint (c_kind, _ct_kind) ->
         iter_kind c_kind
       (* FIXME : use c_kind or ct_kind ?
          For now, as ct_kind is not analyzed,

diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml
index a8ef04e1cde2fa2cdc592fbed940007e0d683dd4..4ccd6dd18676dd6f88b2085477307b65e20789a0 100644 (file)
--- a/ocamldoc/odoc_comments.ml
+++ b/ocamldoc/odoc_comments.ml
@@ -31,7 +31,7 @@ module type Texter =
 module Info_retriever =
   functor (MyTexter : Texter) ->
   struct
-    let create_see file s =
+    let create_see _file s =
       try
         let lexbuf = Lexing.from_string s in
         let (see_ref, s) = Odoc_parser.see_info Odoc_see_lexer.main lexbuf in
@@ -100,31 +100,6 @@ module Info_retriever =
           (0, None)
         end
 
-    (** This function takes a string where a simple comment may has been found. It returns
-       false if there is a blank line or the first comment is a special one, or if there is
-       no comment if the string.*)
-    let nothing_before_simple_comment s =
-      (* get the position of the first "(*" *)
-      try
-        print_DEBUG ("comment_is_attached: "^s);
-        let pos = Str.search_forward (Str.regexp "(\\*") s 0 in
-        let next_char = if (String.length s) >= (pos + 1) then s.[pos + 2] else '_' in
-        (next_char <> '*') &&
-        (
-         (* there is no special comment between the constructor and the coment we got *)
-         let s2 = String.sub s 0 pos in
-         print_DEBUG ("s2="^s2);
-         try
-           let _ = Str.search_forward (Str.regexp ("['\n']"^simple_blank^"*['\n']")) s2 0 in
-           (* a blank line was before the comment *)
-           false
-         with
-           Not_found ->
-             true
-        )
-      with
-        Not_found ->
-          false
 
     (** Return true if the given string contains a blank line. *)
     let blank_line s =
@@ -139,14 +114,14 @@ module Info_retriever =
     let retrieve_info_special file (s : string) =
       retrieve_info Odoc_lexer.main file s
 
-    let retrieve_info_simple file (s : string) =
+    let retrieve_info_simple _file (s : string) =
       Odoc_comments_global.init ();
       Odoc_lexer.comments_level := 0;
       let lexbuf = Lexing.from_string s in
       match Odoc_parser.main Odoc_lexer.simple lexbuf with
         None ->
           (0, None)
-      | Some (desc, remain_opt) ->
+      | Some _ ->
           (!Odoc_comments_global.nb_chars, Some Odoc_types.dummy_info)
 
     (** Return true if the given string contains a blank line outside a simple comment. *)
@@ -168,65 +143,6 @@ module Info_retriever =
       in
       iter s
 
-    (** This function returns the first simple comment in
-       the given string. If strict is [true] then no
-       comment is returned if a blank line or a special
-       comment is found before the simple comment. *)
-    let retrieve_first_info_simple ?(strict=true) file (s : string) =
-      match retrieve_info_simple file s with
-        (_, None) ->
-          (0, None)
-      | (len, Some d) ->
-          (* we check if the comment we got was really attached to the constructor,
-             i.e. that there was no blank line or any special comment "(**" before *)
-          if (not strict) || (nothing_before_simple_comment s) then
-            (* ok, we attach the comment to the constructor *)
-            (len, Some d)
-          else
-            (* a blank line or special comment was before the comment,
-               so we must not attach this comment to the constructor. *)
-            (0, None)
-
-    let retrieve_last_info_simple file (s : string) =
-      print_DEBUG ("retrieve_last_info_simple:"^s);
-      let rec f cur_len cur_d =
-        try
-          let s2 = String.sub s cur_len ((String.length s) - cur_len) in
-          print_DEBUG ("retrieve_last_info_simple.f:"^s2);
-          match retrieve_info_simple file s2 with
-            (len, None) ->
-              print_DEBUG "retrieve_last_info_simple: None";
-              (cur_len + len, cur_d)
-          | (len, Some d) ->
-              print_DEBUG "retrieve_last_info_simple: Some";
-              f (len + cur_len) (Some d)
-        with
-          _ ->
-            print_DEBUG "retrieve_last_info_simple : Erreur String.sub";
-            (cur_len, cur_d)
-      in
-      f 0 None
-
-    let retrieve_last_special_no_blank_after file (s : string) =
-      print_DEBUG ("retrieve_last_special_no_blank_after:"^s);
-      let rec f cur_len cur_d =
-        try
-          let s2 = String.sub s cur_len ((String.length s) - cur_len) in
-          print_DEBUG ("retrieve_last_special_no_blank_after.f:"^s2);
-          match retrieve_info_special file s2 with
-            (len, None) ->
-              print_DEBUG "retrieve_last_special_no_blank_after: None";
-              (cur_len + len, cur_d)
-          | (len, Some d) ->
-              print_DEBUG "retrieve_last_special_no_blank_after: Some";
-              f (len + cur_len) (Some d)
-        with
-          _ ->
-            print_DEBUG "retrieve_last_special_no_blank_after : Erreur String.sub";
-            (cur_len, cur_d)
-      in
-      f 0 None
-
     let all_special file s =
       print_DEBUG ("all_special: "^s);
       let rec iter acc n s2 =
@@ -270,7 +186,7 @@ module Info_retriever =
                    (* should not occur *)
                    (0, None)
               )
-          | (len2, Some d2) ->
+          | (_, Some _) ->
               (0, None)
       in
       print_DEBUG ("just_after_special:end");

diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml
index 6949d3396474a0b0e2d8e8a8b54e53d73fbfc96a..4847e105560b7d2778ae9bea4f1c4844154bcc61 100644 (file)
--- a/ocamldoc/odoc_cross.ml
+++ b/ocamldoc/odoc_cross.ml
@@ -15,7 +15,6 @@
 
 (** Cross referencing. *)
 
-module Name = Odoc_name
 open Odoc_module
 open Odoc_class
 open Odoc_extension
@@ -58,24 +57,23 @@ module P_alias =
          Some (Module_type_alias _) -> true
        | _ -> false
       )
-    let p_class c _ = (false, false)
-    let p_class_type ct _ = (false, false)
-    let p_value v _ = false
+    let p_class _ _ = (false, false)
+    let p_class_type _ _ = (false, false)
+    let p_value _ _ = false
     let p_recfield _ _ _ = false
     let p_const _ _ _ = false
-    let p_type t _ = (false, false)
+    let p_type _ _ = (false, false)
     let p_extension x _ = x.xt_alias <> None
     let p_exception e _ = e.ex_alias <> None
-    let p_attribute a _ = false
-    let p_method m _ = false
-    let p_section s _ = false
+    let p_attribute _ _ = false
+    let p_method _ _ = false
+    let p_section _ _ = false
   end
 
 (** The module used to get the aliased elements. *)
 module Search_alias = Odoc_search.Search (P_alias)
 
 type alias_state =
-    Alias_resolved
   | Alias_to_resolve
 
 (** Couples of module name aliases. *)
@@ -140,36 +138,6 @@ let get_alias_names module_list =
   Hashtbl.clear exception_aliases;
   build_alias_list (Search_alias.search module_list 0)
 
-exception Found of string
-let name_alias =
-  let rec f t name =
-    try
-      match Hashtbl.find t name with
-        (s, Alias_resolved) -> s
-      | (s, Alias_to_resolve) -> f t s
-    with
-      Not_found ->
-        try
-          Hashtbl.iter
-            (fun n2 (n3, _) ->
-              if Name.prefix n2 name then
-                let ln2 = String.length n2 in
-                let s = n3^(String.sub name ln2 ((String.length name) - ln2)) in
-                raise (Found s)
-            )
-            t ;
-          Hashtbl.replace t name (name, Alias_resolved);
-          name
-        with
-          Found s ->
-            let s2 = f t s in
-            Hashtbl.replace t s2 (s2, Alias_resolved);
-            s2
-  in
-  fun name alias_tbl ->
-    f alias_tbl name
-
-
 module Map_ord =
   struct
     type t = string
@@ -188,7 +156,7 @@ let add_known_element name k =
     Not_found ->
       known_elements := Ele_map.add name [k] !known_elements
 
-let rec get_known_elements name =
+let get_known_elements name =
   try Ele_map.find name !known_elements
   with Not_found -> []
 
@@ -322,11 +290,9 @@ let init_known_elements_map module_list =
 
 (** The type to describe the names not found. *)
 type not_found_name =
-    NF_m of Name.t
   | NF_mt of Name.t
   | NF_mmt of Name.t
   | NF_c of Name.t
-  | NF_ct of Name.t
   | NF_cct of Name.t
   | NF_xt of Name.t
   | NF_ex of Name.t
@@ -392,7 +358,7 @@ let rec associate_in_module module_list (acc_b_modif, acc_incomplete_top_module_
      | Module_typeof _ ->
         (acc_b, acc_inc, acc_names)
 
-     | Module_unpack (code, mta) ->
+     | Module_unpack (_code, mta) ->
         begin
           match mta.mta_module with
             Some _ ->
@@ -608,8 +574,8 @@ and associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names
   in
   iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) c.cl_kind
 
-and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct =
-  let rec iter_kind (acc_b, acc_inc, acc_names) k =
+and associate_in_class_type _module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct =
+  let iter_kind (acc_b, acc_inc, acc_names) k =
     match k with
       Class_signature (inher_l, _) ->
         let f (acc_b2, acc_inc2, acc_names2) ic =
@@ -654,7 +620,7 @@ and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_
   in
   iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind
 
-and associate_in_type_extension module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te =
+and associate_in_type_extension _module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te =
   List.fold_left
     (fun (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) xt ->
        match xt.xt_alias with
@@ -754,7 +720,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
                  | Odoc_search.Res_exception e -> (e.ex_name, RK_exception)
                  | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute)
                  | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method)
-                 | Odoc_search.Res_section (_ ,t)-> assert false
+                 | Odoc_search.Res_section _-> assert false
                  | Odoc_search.Res_recfield (t, f) ->
                      (Printf.sprintf "%s.%s" t.ty_name f.rf_name, RK_recfield)
                  | Odoc_search.Res_const (t, f) ->
@@ -791,7 +757,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
              match kind with
              | RK_section _ ->
                  (
-                  (** we just verify that we find an element of this kind with this name *)
+                  (* we just verify that we find an element of this kind with this name *)
                   try
                     let re = Str.regexp ("^"^(Str.quote name)^"$") in
                     let t = Odoc_search.find_section module_list re in
@@ -993,7 +959,7 @@ and assoc_comments_parameter parent_name module_list p =
   match p with
     Simple_name sn ->
       sn.sn_text <- ao (assoc_comments_text parent_name module_list) sn.sn_text
-  | Tuple (l, t) ->
+  | Tuple (l, _) ->
       List.iter (assoc_comments_parameter parent_name module_list) l
 
 and assoc_comments_parameter_list parent_name module_list pl =
@@ -1089,11 +1055,9 @@ let associate module_list =
            Odoc_global.pwarning
              (
               match nf with
-                NF_m n -> Odoc_messages.cross_module_not_found n
               | NF_mt n -> Odoc_messages.cross_module_type_not_found n
               | NF_mmt n -> Odoc_messages.cross_module_or_module_type_not_found n
               | NF_c n -> Odoc_messages.cross_class_not_found n
-              | NF_ct n -> Odoc_messages.cross_class_type_not_found n
               | NF_cct n -> Odoc_messages.cross_class_or_class_type_not_found n
               | NF_xt n -> Odoc_messages.cross_extension_not_found n
               | NF_ex n -> Odoc_messages.cross_exception_not_found n

diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml
index 834aa59574c19e87c34f30a4d6bbcd57ebfe1a80..c18c0568ed62d572aba25fb0e082e6f8f11419dd 100644 (file)
--- a/ocamldoc/odoc_dag2html.ml
+++ b/ocamldoc/odoc_dag2html.ml
@@ -32,9 +32,7 @@ and ghost_id
 ;;
 
 external span_id_of_int : int -> span_id = "%identity";;
-external int_of_span_id : span_id -> int = "%identity";;
 external ghost_id_of_int : int -> ghost_id = "%identity";;
-external int_of_ghost_id : ghost_id -> int = "%identity";;
 
 let new_span_id = let i = ref 0 in fun () -> incr i; span_id_of_int !i;;
 
@@ -44,7 +42,6 @@ let new_ghost_id = let i = ref 0 in fun () -> incr i; ghost_id_of_int !i;;
 
 type align = LeftA | CenterA | RightA;;
 type table_data = TDstring of string | TDhr of align;;
-type html_table = (int * align * table_data) array array;;
 
 let html_table_struct indi_txt phony d t =
   let phony =
@@ -315,7 +312,11 @@ let ancestors d =
 ;;
 
 let get_children d parents =
-  let rec merge_children children el =
+  (* XXXX merge_children used to be declared as a recursive function,
+     but it was not.  I've not idea if it a bug or not.  One should
+     either fix it (if this is a bug), or simplify the code otherwise. *)
+
+  let merge_children children el =
     List.fold_right
       (fun (x, _) children ->
          match x with
@@ -419,7 +420,7 @@ let treat_new_row d t =
   let i = Array.length t.table - 1 in
   let rec loop t i j =
     match get_block t i j with
-      Some (parents, max_parent_colspan, span) ->
+      Some (parents, max_parent_colspan, _span) ->
         let children = get_children d parents in
         let children =
           if children = [] then [{elem = Nothing; span = new_span_id ()}]
@@ -499,7 +500,7 @@ let treat_new_row d t =
   loop t i 0
 ;;
 
-let down_it t i k y =
+let down_it t i k =
   t.table.(Array.length t.table - 1).(k) <- t.table.(i).(k);
   for r = i to Array.length t.table - 2 do
     t.table.(r).(k) <- {elem = Ghost (new_ghost_id ()); span = new_span_id ()}
@@ -530,7 +531,7 @@ let equilibrate t =
                 if k = len then loop1 (i + 1)
                 else
                   match t.table.(i).(k).elem with
-                    Elem y when x = y -> down_it t i k y; loop 0
+                    Elem y when x = y -> down_it t i k; loop 0
                   | _ -> loop2 (k + 1)
               in
               loop2 0
@@ -764,7 +765,7 @@ let find_block_with_parents t i jj1 jj2 jj3 jj4 =
   loop i jj1 jj2 jj3 jj4
 ;;
 
-let push_to_right d t i j1 j2 =
+let push_to_right t i j1 j2 =
   let line = t.(i) in
   let rec loop j =
     if j = j2 then j - 1
@@ -806,7 +807,7 @@ let push_to_right d t i j1 j2 =
   loop (j1 + 1)
 ;;
 
-let push_to_left d t i j1 j2 =
+let push_to_left t i j1 j2 =
   let line = t.(i) in
   let rec loop j =
     if j = j1 then j + 1
@@ -848,7 +849,7 @@ let push_to_left d t i j1 j2 =
   loop (j2 - 1)
 ;;
 
-let fill_gap d t i j1 j2 =
+let fill_gap t i j1 j2 =
   let t1 =
     let t1 = Array.copy t.table in
     for i = 0 to Array.length t.table - 1 do
@@ -859,8 +860,8 @@ let fill_gap d t i j1 j2 =
     done;
     t1
   in
-  let j2 = push_to_left d t1 i j1 j2 in
-  let j1 = push_to_right d t1 i j1 j2 in
+  let j2 = push_to_left t1 i j1 j2 in
+  let j1 = push_to_right t1 i j1 j2 in
   if j1 = j2 - 1 then
     let line = t1.(i - 1) in
     let x = line.(j1).span in
@@ -877,7 +878,7 @@ let fill_gap d t i j1 j2 =
   else None
 ;;
 
-let treat_gaps d t =
+let treat_gaps t =
   let i = Array.length t.table - 1 in
   let rec loop t j =
     let line = t.table.(i) in
@@ -890,7 +891,7 @@ let treat_gaps d t =
             let rec loop1 t j1 =
               if j1 < 0 then loop t (j + 1)
               else if y = line.(j1).elem then
-                match fill_gap d t i j1 j with
+                match fill_gap t i j1 j with
                   Some (t, ok) -> if ok then loop t 2 else loop t (j + 1)
                 | None -> loop t (j + 1)
               else loop1 t (j1 - 1)
@@ -947,7 +948,7 @@ let tablify phony no_optim no_group d =
           group_ghost t;
           group_children t;
           group_span_by_common_children d t;
-          let t = if no_optim then t else treat_gaps d t in
+          let t = if no_optim then t else treat_gaps t in
           group_span_last_row t;
           t
         end
@@ -957,7 +958,7 @@ let tablify phony no_optim no_group d =
   loop t
 ;;
 
-let fall d t =
+let fall t =
   for i = 1 to Array.length t.table - 1 do
     let line = t.table.(i) in
     let rec loop j =
@@ -1023,7 +1024,7 @@ let fall d t =
   done
 ;;
 
-let fall2_cool_right t i1 i2 i3 j1 j2 =
+let fall2_cool_right t i1 i2 _i3 j1 j2 =
   let span = t.table.(i2 - 1).(j1).span in
   for i = i2 - 1 downto 0 do
     for j = j1 to j2 - 1 do
@@ -1048,7 +1049,7 @@ let fall2_cool_right t i1 i2 i3 j1 j2 =
   loop j1
 ;;
 
-let fall2_cool_left t i1 i2 i3 j1 j2 =
+let fall2_cool_left t i1 i2 _i3 j1 j2 =
   let span = t.table.(i2 - 1).(j2).span in
   for i = i2 - 1 downto 0 do
     for j = j1 + 1 to j2 do
@@ -1097,7 +1098,7 @@ let do_fall2_right t i1 i2 j1 j2 =
         else
           let new_line =
             Array.init (Array.length t.table.(0))
-              (fun i -> {elem = Nothing; span = new_span_id ()})
+              (fun _ -> {elem = Nothing; span = new_span_id ()})
           in
           let t = {table = Array.append t.table [| new_line |]} in
           loop (cnt - 1) t
@@ -1132,7 +1133,7 @@ let do_fall2_left t i1 i2 j1 j2 =
         else
           let new_line =
             Array.init (Array.length t.table.(0))
-              (fun i -> {elem = Nothing; span = new_span_id ()})
+              (fun _ -> {elem = Nothing; span = new_span_id ()})
           in
           let t = {table = Array.append t.table [| new_line |]} in
           loop (cnt - 1) t
@@ -1447,7 +1448,7 @@ let table_of_dag phony no_optim invert no_group d =
   let d = if invert then invert_dag d else d in
   let t = tablify phony no_optim no_group d in
   let t = if invert then invert_table t else t in
-  fall () t;
+  fall t;
   let t = fall2_right t in
   let t = fall2_left t in
   let t = shorten_too_long t in
@@ -1455,148 +1456,8 @@ let table_of_dag phony no_optim invert no_group d =
 ;;
 
 
-let version = "1.01";;
-
 (* input dag *)
 
-let strip_spaces str =
-  let start =
-    let rec loop i =
-      if i == String.length str then i
-      else
-        match str.[i] with
-          ' ' | '\013' | '\n' | '\t' -> loop (i + 1)
-        | _ -> i
-    in
-    loop 0
-  in
-  let stop =
-    let rec loop i =
-      if i == -1 then i + 1
-      else
-        match str.[i] with
-          ' ' | '\013' | '\n' | '\t' -> loop (i - 1)
-        | _ -> i + 1
-    in
-    loop (String.length str - 1)
-  in
-  if start == 0 && stop == String.length str then str
-  else if start > stop then ""
-  else String.sub str start (stop - start)
-;;
-
-let rec get_line ic =
-  try
-    let line = input_line ic in
-    if String.length line > 0 && line.[0] = '#' then get_line ic
-    else Some (strip_spaces line)
-  with
-    End_of_file -> None
-;;
-
-let input_dag ic =
-  let rec find cnt s =
-    function
-      n :: nl ->
-        if n.valu = s then n, idag_of_int cnt else find (cnt - 1) s nl
-    | [] -> raise Not_found
-  in
-  let add_node pl cl nl cnt =
-    let cl = List.rev cl in
-    let pl = List.rev pl in
-    let (pl, pnl, nl, cnt) =
-      List.fold_left
-        (fun (pl, pnl, nl, cnt) p ->
-           try
-             let (n, p) = find (cnt - 1) p nl in p :: pl, n :: pnl, nl, cnt
-           with
-             Not_found ->
-               let n = {pare = []; valu = p; chil = []} in
-               let p = idag_of_int cnt in p :: pl, n :: pnl, n :: nl, cnt + 1)
-        ([], [], nl, cnt) pl
-    in
-    let pl = List.rev pl in
-    let (cl, nl, cnt) =
-      List.fold_left
-        (fun (cl, nl, cnt) c ->
-           try
-             let (n, c) = find (cnt - 1) c nl in
-             n.pare <- n.pare @ pl; c :: cl, nl, cnt
-           with
-             Not_found ->
-               let n = {pare = pl; valu = c; chil = []} in
-               let c = idag_of_int cnt in c :: cl, n :: nl, cnt + 1)
-        ([], nl, cnt) cl
-    in
-    let cl = List.rev cl in
-    List.iter (fun p -> p.chil <- p.chil @ cl) pnl; nl, cnt
-  in
-  let rec input_parents nl pl cnt =
-    function
-      Some "" -> input_parents nl pl cnt (get_line ic)
-    | Some line ->
-        begin match line.[0] with
-          'o' ->
-            let p =
-              strip_spaces (String.sub line 1 (String.length line - 1))
-            in
-            if p = "" then failwith line
-            else input_parents nl (p :: pl) cnt (get_line ic)
-        | '-' ->
-            if pl = [] then failwith line
-            else input_children nl pl [] cnt (Some line)
-        | _ -> failwith line
-        end
-    | None -> if pl = [] then nl, cnt else failwith "end of file 1"
-  and input_children nl pl cl cnt =
-    function
-      Some "" -> input_children nl pl cl cnt (get_line ic)
-    | Some line ->
-        begin match line.[0] with
-          'o' ->
-            if cl = [] then failwith line
-            else
-              let (nl, cnt) = add_node pl cl nl cnt in
-              input_parents nl [] cnt (Some line)
-        | '-' ->
-            let c =
-              strip_spaces (String.sub line 1 (String.length line - 1))
-            in
-            if c = "" then failwith line
-            else input_children nl pl (c :: cl) cnt (get_line ic)
-        | _ -> failwith line
-        end
-    | None ->
-        if cl = [] then failwith "end of file 2" else add_node pl cl nl cnt
-  in
-  let (nl, _) = input_parents [] [] 0 (get_line ic) in
-  {dag = Array.of_list (List.rev nl)}
-;;
-
-(* testing *)
-
-let map_dag f d =
-  let a =
-    Array.map (fun d -> {pare = d.pare; valu = f d.valu; chil = d.chil}) d.dag
-  in
-  {dag = a}
-;;
-
-let tag_dag d =
-  let c = ref 'A' in
-  map_dag
-    (fun v ->
-       let v = !c in
-       c :=
-         if !c = 'Z' then 'a'
-         else if !c = 'z' then '1'
-         else Char.chr (Char.code !c + 1);
-       String.make 1 v)
-    d
-;;
-
-(* *)
-
 let phony _ = false;;
 let indi_txt n = n.valu;;
 
@@ -1638,9 +1499,7 @@ let string_table border hts =
   Buffer.contents buf
 ;;
 
-let fname = ref "";;
 let invert = ref false;;
-let char = ref false;;
 let border = ref 0;;
 let no_optim = ref false;;
 let no_group = ref false;;

diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml
index caa2999f2db51a150ee98b789fe7b316054c4862..ffb1dd20b76be1dacac7d913e684dc992cb35042 100644 (file)
--- a/ocamldoc/odoc_env.ml
+++ b/ocamldoc/odoc_env.ml
@@ -137,11 +137,11 @@ let full_module_or_module_type_name env n =
 let full_type_name env n =
   try
     let full = List.assoc n env.env_types in
-(**    print_string ("type "^n^" is "^full);
+(*    print_string ("type "^n^" is "^full);
     print_newline ();*)
     full
   with Not_found ->
-(**    print_string ("type "^n^" not found");
+(*    print_string ("type "^n^" not found");
     print_newline ();*)
     n
 
@@ -174,9 +174,6 @@ let full_class_or_class_type_name env n =
   try List.assoc n env.env_classes
   with Not_found -> full_class_type_name env n
 
-let print_env_types env =
-  List.iter (fun (s1,s2) -> Printf.printf "%s = %s\n" s1 s2) env.env_types
-
 let subst_type env t =
 (*
   print_string "Odoc_env.subst_type\n";
@@ -190,7 +187,7 @@ let subst_type env t =
       deja_vu := t :: !deja_vu;
       Btype.iter_type_expr iter t;
       match t.Types.desc with
-      | Types.Tconstr (p, [ty], a) when Path.same p Predef.path_option ->
+      | Types.Tconstr (p, [_], _) when Path.same p Predef.path_option ->
           ()
       | Types.Tconstr (p, l, a) ->
           let new_p =
@@ -239,7 +236,7 @@ let subst_class_type env t =
         let new_texp_list = List.map (subst_type env) texp_list in
         let new_ct = iter ct in
         Types.Cty_constr (new_p, new_texp_list, new_ct)
-    | Types.Cty_signature cs ->
+    | Types.Cty_signature _ ->
         (* we don't handle vals and methods *)
         t
     | Types.Cty_arrow (l, texp, ct) ->

diff --git a/ocamldoc/odoc_gen.ml b/ocamldoc/odoc_gen.ml
index 2ff122ddcd6be4e9e5c64c109b0112d9c7f77e21..8ea2c947775d484a71e195f69bfb5f8fcdbba470 100644 (file)
--- a/ocamldoc/odoc_gen.ml
+++ b/ocamldoc/odoc_gen.ml
@@ -23,7 +23,7 @@ module type Base = sig
   end;;
 
 module Base_generator : Base = struct
-  class generator : doc_generator = object method generate l = () end
+  class generator : doc_generator = object method generate _ = () end
   end;;
 
 module type Base_functor = functor (G: Base) -> Base

diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml
index 08f1c5488a13990a47f6da1e71ed683ccd9343f9..fa366eae0986dccbd0c83dc35fc5520408bac21e 100644 (file)
--- a/ocamldoc/odoc_global.ml
+++ b/ocamldoc/odoc_global.ml
@@ -18,8 +18,6 @@
 (* Tell ocaml compiler not to generate files. *)
 let _ = Clflags.dont_write_files := true
 
-open Clflags
-
 type source_file =
     Impl_file of string
   | Intf_file of string

diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli
index a3af6afe389828f0f4e1261e51eec93540ff7f66..c4c38096e23d6647703860071767619e78098755 100644 (file)
--- a/ocamldoc/odoc_global.mli
+++ b/ocamldoc/odoc_global.mli
@@ -62,6 +62,7 @@ val hidden_modules : string list ref
 
 (** The files to be analysed. *)
 val files : source_file list ref
+
 (** A counter for errors. *)
 val errors : int ref
 

diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml
index c666afe9d57fc2aeef90db6eae52ae369305e707..0fe22af19622e7fd0fd495080314f71440bd66b9 100644 (file)
--- a/ocamldoc/odoc_html.ml
+++ b/ocamldoc/odoc_html.ml
@@ -18,7 +18,6 @@
 let print_DEBUG s = print_string s ; print_newline ()
 
 open Odoc_info
-open Parameter
 open Value
 open Type
 open Extension
@@ -107,6 +106,10 @@ module Naming =
     let recfield_target t f = target mark_type_elt
       (Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.rf_name)
 
+    (** Return the link target for the given inline record field. *)
+    let inline_recfield_target t c f = target mark_type_elt
+      (Printf.sprintf "%s.%s.%s" t c f.rf_name)
+
     (** Return the link target for the given object field. *)
     let objfield_target t f = target mark_type_elt
       (Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.of_name)
@@ -222,7 +225,7 @@ end)
 
 (** A class with a method to colorize a string which represents OCaml code. *)
 class ocaml_code =
-  object(self)
+  object
     method html_of_code b ?(with_pre=true) code =
       Odoc_ocamlhtml.html_of_code b ~with_pre: with_pre code
   end
@@ -300,7 +303,7 @@ class virtual text =
       | Odoc_info.Custom (s,t) -> self#html_of_custom_text b s t
       | Odoc_info.Target (target, code) -> self#html_of_Target b ~target ~code
 
-    method html_of_custom_text b s t = ()
+    method html_of_custom_text _ _ _ = ()
 
     method html_of_Target b ~target ~code =
       if String.lowercase_ascii target = "html" then bs b code else ()
@@ -433,7 +436,7 @@ class virtual text =
       bs b tag_c;
       bs b ">"
 
-    method html_of_Latex b _ = ()
+    method html_of_Latex _ _ = ()
       (* don't care about LaTeX stuff in HTML. *)
 
     method html_of_Link b s t =
@@ -778,11 +781,15 @@ class html =
 
     val mutable doctype =
       "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n"
-    method character_encoding () =
-      Printf.sprintf
+    method character_encoding b =
+      bp b
         "<meta content=\"text/html; charset=%s\" http-equiv=\"Content-Type\">\n"
         !charset
 
+    method meta b =
+      self#character_encoding b;
+      bs b "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">\n"
+
     (** The default style options. *)
     val mutable default_style_options =
       [ ".keyword { font-weight : bold ; color : Red }" ;
@@ -898,22 +905,31 @@ class html =
 
     (** The file for the index of values. *)
     method index_values = Printf.sprintf "%s_values.html" self#index_prefix
+
     (** The file for the index of types. *)
     method index_types = Printf.sprintf "%s_types.html" self#index_prefix
+
     (** The file for the index of extensions. *)
     method index_extensions = Printf.sprintf "%s_extensions.html" self#index_prefix
+
     (** The file for the index of exceptions. *)
     method index_exceptions = Printf.sprintf "%s_exceptions.html" self#index_prefix
+
     (** The file for the index of attributes. *)
     method index_attributes = Printf.sprintf "%s_attributes.html" self#index_prefix
+
     (** The file for the index of methods. *)
     method index_methods = Printf.sprintf "%s_methods.html" self#index_prefix
+
     (** The file for the index of classes. *)
     method index_classes = Printf.sprintf "%s_classes.html" self#index_prefix
+
     (** The file for the index of class types. *)
     method index_class_types = Printf.sprintf "%s_class_types.html" self#index_prefix
+
     (** The file for the index of modules. *)
     method index_modules = Printf.sprintf "%s_modules.html" self#index_prefix
+
     (** The file for the index of module types. *)
     method index_module_types = Printf.sprintf "%s_module_types.html" self#index_prefix
 
@@ -921,36 +937,45 @@ class html =
     (** The list of attributes. Filled in the [generate] method. *)
     val mutable list_attributes = []
     method list_attributes = list_attributes
+
     (** The list of methods. Filled in the [generate] method. *)
     val mutable list_methods = []
     method list_methods = list_methods
+
     (** The list of values. Filled in the [generate] method. *)
     val mutable list_values = []
     method list_values = list_values
+
     (** The list of extensions. Filled in the [generate] method. *)
     val mutable list_extensions = []
     method list_extensions = list_extensions
+
     (** The list of exceptions. Filled in the [generate] method. *)
     val mutable list_exceptions = []
     method list_exceptions = list_exceptions
+
     (** The list of types. Filled in the [generate] method. *)
     val mutable list_types = []
     method list_types = list_types
+
     (** The list of modules. Filled in the [generate] method. *)
     val mutable list_modules = []
     method list_modules = list_modules
+
     (** The list of module types. Filled in the [generate] method. *)
     val mutable list_module_types = []
     method list_module_types = list_module_types
+
     (** The list of classes. Filled in the [generate] method. *)
     val mutable list_classes = []
     method list_classes = list_classes
+
     (** The list of class types. Filled in the [generate] method. *)
     val mutable list_class_types = []
     method list_class_types = list_class_types
 
     (** The header of pages. Must be prepared by the [prepare_header] method.*)
-    val mutable header = fun b -> fun ?(nav=None) -> fun ?(comments=[]) -> fun _ -> ()
+    val mutable header = fun _ -> fun ?nav:_ -> fun ?comments:_ -> fun _ -> ()
 
     (** Init the style. *)
     method init_style =
@@ -1002,7 +1027,7 @@ class html =
         in
         bs b "<head>\n";
         bs b style;
-        bs b (self#character_encoding ()) ;
+        self#meta b;
         bs b "<link rel=\"Start\" href=\"";
         bs b self#index;
         bs b "\">\n" ;
@@ -1133,14 +1158,14 @@ class html =
     method constructor s = "<span class=\"constructor\">"^s^"</span>"
 
     (** Output the given ocaml code to the given file name. *)
-    method private output_code in_title file code =
+    method private output_code ?(with_pre=true) in_title file code =
       try
         let chanout = open_out file in
         let b = new_buf () in
         bs b "<html>";
         self#print_header b (self#inner_title in_title);
         bs b"<body>\n";
-        self#html_of_code b code;
+        self#html_of_code ~with_pre b code;
         bs b "</body></html>";
         Buffer.output_buffer chanout b;
         close_out chanout
@@ -1208,21 +1233,23 @@ class html =
       bs b "</code>"
 
     (** Print html code to display a [Types.type_expr list]. *)
-    method html_of_cstr_args ?par b m_name sep l =
+    method html_of_cstr_args ?par b m_name c_name sep l =
       print_DEBUG "html#html_of_cstr_args";
-      let s =
-        match l with
-        | Cstr_tuple l ->
-            Odoc_info.string_of_type_list ?par sep l
-        | Cstr_record l ->
-            Odoc_info.string_of_record l
-      in
-      print_DEBUG "html#html_of_cstr_args: 1";
-      let s2 = newline_to_indented_br s in
-      print_DEBUG "html#html_of_cstr_args: 2";
-      bs b "<code class=\"type\">";
-      bs b (self#create_fully_qualified_idents_links m_name s2);
-      bs b "</code>"
+      match l with
+      | Cstr_tuple l ->
+          print_DEBUG "html#html_of_cstr_args: 1";
+          let s = Odoc_info.string_of_type_list ?par sep l in
+          let s2 = newline_to_indented_br s in
+          print_DEBUG "html#html_of_cstr_args: 2";
+          bs b "<code class=\"type\">";
+          bs b (self#create_fully_qualified_idents_links m_name s2);
+          bs b "</code>"
+      | Cstr_record l ->
+          print_DEBUG "html#html_of_cstr_args: 1 bis";
+          bs b "<code>";
+          self#html_of_record ~father:m_name ~close_env: "</code>"
+            (Naming.inline_recfield_target m_name c_name)
+            b l
 
     (** Print html code to display a [Types.type_expr list] as type parameters
        of a class of class type. *)
@@ -1305,7 +1332,7 @@ class html =
           bs b "<code class=\"type\"> ";
           bs b (self#create_fully_qualified_module_idents_links father s);
           bs b "</code>"
-      | Module_constraint (k, tk) ->
+      | Module_constraint (k, _tk) ->
           (* TODO: what to print ? *)
           self#html_of_module_kind b father ?modu k
       | Module_typeof s ->
@@ -1412,12 +1439,12 @@ class html =
     (** Generate a file containing the module type in the given file name. *)
     method output_module_type in_title file mtyp =
       let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_module_type ~complete: true mtyp) in
-      self#output_code in_title file s
+      self#output_code ~with_pre:false in_title file s
 
     (** Generate a file containing the class type in the given file name. *)
     method output_class_type in_title file ctyp =
       let s = Odoc_info.remove_ending_newline (Odoc_info.string_of_class_type ~complete: true ctyp) in
-      self#output_code in_title file s
+      self#output_code ~with_pre:false in_title file s
 
     (** Print html code for a value. *)
     method html_of_value b v =
@@ -1464,6 +1491,7 @@ class html =
       bs b "<table class=\"typetable\">\n";
       let print_one x =
         let father = Name.father x.xt_name in
+        let cname = Name.simple x.xt_name in
         bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
         bs b "<code>";
         bs b (self#keyword "|");
@@ -1471,19 +1499,19 @@ class html =
         bs b "<code>";
         bp b "<span id=\"%s\">%s</span>"
           (Naming.extension_target x)
-          (Name.simple x.xt_name);
+          cname;
         (
           match x.xt_args, x.xt_ret with
               Cstr_tuple [], None -> ()
             | l,None ->
                 bs b (" " ^ (self#keyword "of") ^ " ");
-                self#html_of_cstr_args ~par: false b father " * " l;
+                self#html_of_cstr_args ~par: false b father cname " * " l;
             | Cstr_tuple [],Some r ->
                 bs b (" " ^ (self#keyword ":") ^ " ");
                 self#html_of_type_expr b father r;
             | l,Some r ->
                 bs b (" " ^ (self#keyword ":") ^ " ");
-                self#html_of_cstr_args ~par: false b father " * " l;
+                self#html_of_cstr_args ~par: false b father cname " * " l;
                 bs b (" " ^ (self#keyword "->") ^ " ");
                 self#html_of_type_expr b father r;
         );
@@ -1526,29 +1554,31 @@ class html =
 
     (** Print html code for an exception. *)
     method html_of_exception b e =
+      let cname = Name.simple e.ex_name in
       Odoc_info.reset_type_names ();
       bs b "\n<pre>";
       bp b "<span id=\"%s\">" (Naming.exception_target e);
       bs b (self#keyword "exception");
       bs b " ";
-      bs b (Name.simple e.ex_name);
+      bs b cname;
       bs b "</span>";
       (
+        let father = Name.father e.ex_name in
         match e.ex_args, e.ex_ret with
           Cstr_tuple [], None -> ()
-        | l,None ->
+        | _,None ->
             bs b (" "^(self#keyword "of")^" ");
             self#html_of_cstr_args
-                   ~par: false b (Name.father e.ex_name) " * " e.ex_args
+                   ~par:false b father cname " * " e.ex_args
         | Cstr_tuple [],Some r ->
             bs b (" " ^ (self#keyword ":") ^ " ");
-            self#html_of_type_expr b (Name.father e.ex_name) r;
+            self#html_of_type_expr b father r;
         | l,Some r ->
             bs b (" " ^ (self#keyword ":") ^ " ");
             self#html_of_cstr_args
-                   ~par: false b (Name.father e.ex_name) " * " l;
+                   ~par:false b father cname " * " l;
             bs b (" " ^ (self#keyword "->") ^ " ");
-            self#html_of_type_expr b (Name.father e.ex_name) r;
+            self#html_of_type_expr b father r;
       );
       (
        match e.ex_alias with
@@ -1565,6 +1595,38 @@ class html =
       bs b "</pre>\n";
       self#html_of_info b e.ex_info
 
+    method html_of_record ~father ~close_env gen_name  b l =
+      bs b "{";
+      bs b close_env;
+      bs b "<table class=\"typetable\">\n" ;
+      let print_one r =
+        bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
+        bs b "<code>&nbsp;&nbsp;</code>";
+        bs b "</td>\n<td align=\"left\" valign=\"top\" >\n";
+        bs b "<code>";
+        if r.rf_mutable then bs b (self#keyword "mutable&nbsp;") ;
+        bp b "<span id=\"%s\">%s</span>&nbsp;: " (gen_name r) r.rf_name;
+        self#html_of_type_expr b father r.rf_type;
+        bs b ";</code></td>\n";
+        (
+          match r.rf_text with
+            None -> ()
+          | Some t ->
+              bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
+              bs b "<code>";
+              bs b "(*";
+              bs b "</code></td>";
+              bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
+              self#html_of_info b (Some t);
+              bs b "</td><td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
+              bs b "<code>*)</code></td>";
+        );
+        bs b "\n</tr>"
+      in
+      print_concat b "\n" print_one l;
+      bs b "</table>\n}\n"
+
+
     (** Print html code for a type. *)
     method html_of_type b t =
       Odoc_info.reset_type_names ();
@@ -1658,13 +1720,13 @@ class html =
                Cstr_tuple [], None -> ()
              | l,None ->
                  bs b (" " ^ (self#keyword "of") ^ " ");
-                 self#html_of_cstr_args ~par: false b father " * " l;
+                 self#html_of_cstr_args ~par:false b father constr.vc_name " * " l;
              | Cstr_tuple [],Some r ->
                  bs b (" " ^ (self#keyword ":") ^ " ");
                  self#html_of_type_expr b father r;
              | l,Some r ->
                  bs b (" " ^ (self#keyword ":") ^ " ");
-                 self#html_of_cstr_args ~par: false b father " * " l;
+                 self#html_of_cstr_args ~par: false b father constr.vc_name " * " l;
                  bs b (" " ^ (self#keyword "->") ^ " ");
                  self#html_of_type_expr b father r;
             );
@@ -1693,42 +1755,10 @@ class html =
       | Type_record l ->
           bs b "= ";
           if priv then bs b "private " ;
-          bs b "{";
-          bs b
-            (
-             match t.ty_manifest with
-               None -> "</code></pre>"
-             | Some _ -> "</pre>"
-            );
-          bs b "<table class=\"typetable\">\n" ;
-          let print_one r =
-            bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n";
-            bs b "<code>&nbsp;&nbsp;</code>";
-            bs b "</td>\n<td align=\"left\" valign=\"top\" >\n";
-            bs b "<code>";
-            if r.rf_mutable then bs b (self#keyword "mutable&nbsp;") ;
-            bp b "<span id=\"%s\">%s</span>&nbsp;: "
-              (Naming.recfield_target t r)
-              r.rf_name;
-            self#html_of_type_expr b father r.rf_type;
-            bs b ";</code></td>\n";
-            (
-             match r.rf_text with
-               None -> ()
-             | Some t ->
-                 bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
-                 bs b "<code>";
-                 bs b "(*";
-                 bs b "</code></td>";
-                 bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >";
-                 self#html_of_info b (Some t);
-                 bs b "</td><td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >";
-                 bs b "<code>*)</code></td>";
-            );
-            bs b "\n</tr>"
-          in
-          print_concat b "\n" print_one l;
-          bs b "</table>\n}\n"
+          let close_env = match t.ty_manifest with
+              None -> "</code></pre>"
+            | Some _ -> "</pre>" in
+          self#html_of_record ~father ~close_env (Naming.recfield_target t) b l
       | Type_open ->
           bs b "= ..";
           bs b "</pre>"
@@ -1860,7 +1890,7 @@ class html =
           bs b "</table>\n</td>\n</tr>\n</table></div>\n"
 
     (** Print html code for the parameters which have a name and description. *)
-    method html_of_described_parameter_list b m_name l =
+    method html_of_described_parameter_list b _m_name l =
       (* get the params which have a name, and at least one name described. *)
       let l2 = List.filter
           (fun p ->
@@ -2024,7 +2054,7 @@ class html =
           );
           self#html_of_text b [Code "end"]
 
-      | Class_apply capp ->
+      | Class_apply _ ->
           (* TODO: display final type from typedtree *)
           self#html_of_text b [Raw "class application not handled yet"]
 
@@ -2245,7 +2275,7 @@ class html =
             ()
         | Class_structure (l, _) ->
             self#generate_inheritance_info b l
-        | Class_constraint (k, ct) ->
+        | Class_constraint (k, _) ->
             iter_kind k
         | Class_apply _
         | Class_constr _ ->
@@ -2571,7 +2601,7 @@ class html =
         match modu.m_code with
           None -> ()
         | Some code ->
-            self#output_code
+            self#output_code ~with_pre:false
               modu.m_name
               (Filename.concat !Global.target_dir code_file)
               code
@@ -2605,7 +2635,7 @@ class html =
              bs b "<br/>";
              self#html_of_Module_list b
                (List.map (fun m -> m.m_name) module_list);
-         | Some i -> self#html_of_info ~indent: false b info
+         | Some _ -> self#html_of_info ~indent: false b info
         );
         bs b "</body>\n</html>";
         Buffer.output_buffer chanout b;
@@ -2615,7 +2645,7 @@ class html =
           raise (Failure s)
 
     (** Generate the values index in the file [index_values.html]. *)
-    method generate_values_index module_list =
+    method generate_values_index _module_list =
       self#generate_elements_index
         self#list_values
         (fun v -> v.val_name)
@@ -2625,7 +2655,7 @@ class html =
         self#index_values
 
     (** Generate the extensions index in the file [index_extensions.html]. *)
-    method generate_extensions_index module_list =
+    method generate_extensions_index _module_list =
       self#generate_elements_index
         self#list_extensions
         (fun x -> x.xt_name)
@@ -2635,7 +2665,7 @@ class html =
         self#index_extensions
 
     (** Generate the exceptions index in the file [index_exceptions.html]. *)
-    method generate_exceptions_index module_list =
+    method generate_exceptions_index _module_list =
       self#generate_elements_index
         self#list_exceptions
         (fun e -> e.ex_name)
@@ -2645,7 +2675,7 @@ class html =
         self#index_exceptions
 
     (** Generate the types index in the file [index_types.html]. *)
-    method generate_types_index module_list =
+    method generate_types_index _module_list =
       self#generate_elements_index
         self#list_types
         (fun t -> t.ty_name)
@@ -2655,7 +2685,7 @@ class html =
         self#index_types
 
     (** Generate the attributes index in the file [index_attributes.html]. *)
-    method generate_attributes_index module_list =
+    method generate_attributes_index _module_list =
       self#generate_elements_index
         self#list_attributes
         (fun a -> a.att_value.val_name)
@@ -2665,7 +2695,7 @@ class html =
         self#index_attributes
 
     (** Generate the methods index in the file [index_methods.html]. *)
-    method generate_methods_index module_list =
+    method generate_methods_index _module_list =
       self#generate_elements_index
         self#list_methods
         (fun m -> m.met_value.val_name)
@@ -2675,7 +2705,7 @@ class html =
         self#index_methods
 
     (** Generate the classes index in the file [index_classes.html]. *)
-    method generate_classes_index module_list =
+    method generate_classes_index _module_list =
       self#generate_elements_index
         self#list_classes
         (fun c -> c.cl_name)
@@ -2685,7 +2715,7 @@ class html =
         self#index_classes
 
     (** Generate the class types index in the file [index_class_types.html]. *)
-    method generate_class_types_index module_list =
+    method generate_class_types_index _module_list =
       self#generate_elements_index
         self#list_class_types
         (fun ct -> ct.clt_name)
@@ -2695,7 +2725,7 @@ class html =
         self#index_class_types
 
     (** Generate the modules index in the file [index_modules.html]. *)
-    method generate_modules_index module_list =
+    method generate_modules_index _module_list =
       self#generate_elements_index
         self#list_modules
         (fun m -> m.m_name)
@@ -2705,7 +2735,7 @@ class html =
         self#index_modules
 
     (** Generate the module types index in the file [index_module_types.html]. *)
-    method generate_module_types_index module_list =
+    method generate_module_types_index _module_list =
       self#generate_elements_index
         self#list_module_types
         (fun mt -> mt.mt_name)

diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index f014647264f5fb033873fdc5ec059cbba291ba11..d7c3677736cbd5e00ff54f0f55abbf9f9bb4ebca 100644 (file)
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -136,6 +136,7 @@ module Name :
 module Parameter :
   sig
     (** {3 Types} *)
+
     (** Representation of a simple parameter name *)
     type simple_name = Odoc_parameter.simple_name =
         {
@@ -154,6 +155,7 @@ module Parameter :
     type parameter = param_info
 
     (** {3 Functions} *)
+
     (** Acces to the name as a string. For tuples, parenthesis and commas are added. *)
     val complete_name : parameter -> string
 
@@ -342,6 +344,7 @@ module Value :
 module Class :
   sig
     (** {3 Types} *)
+
     (** To keep the order of elements in a class. *)
     type class_element = Odoc_class.class_element =
         Class_attribute of Value.t_attribute
@@ -463,6 +466,7 @@ module Class :
 module Module :
   sig
     (** {3 Types} *)
+
     (** To keep the order of elements in a module. *)
     type module_element = Odoc_module.module_element =
         Element_module of t_module
@@ -914,7 +918,6 @@ module Scan :
   sig
     class scanner :
       object
-      (** Scan of 'leaf elements'. *)
 
         method scan_value : Value.t_value -> unit
 

diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index 10a10adaa70e6713cc8181f5585a84b5b8495e1a..37252d63fd6678b943c833346fb4e9a2e765d7fa 100644 (file)
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -18,7 +18,6 @@
 let print_DEBUG s = print_string s ; print_newline ()
 
 open Odoc_info
-open Parameter
 open Value
 open Type
 open Extension
@@ -69,6 +68,14 @@ let ps f s = Format.fprintf f "%s" s
 let bp = Printf.bprintf
 let bs = Buffer.add_string
 
+let rec merge_codepre = function
+    [] -> []
+  | [e] -> [e]
+  | (CodePre s1) :: (CodePre s2) :: q ->
+      merge_codepre ((CodePre (s1^"\n"^s2)) :: q)
+  | e :: q ->
+      e :: (merge_codepre q)
+
 let print_concat fmt sep f =
   let rec iter = function
       [] -> ()
@@ -293,7 +300,7 @@ class text =
       | Odoc_info.Custom (s,t) -> self#latex_of_custom_text fmt s t
       | Odoc_info.Target (target, code) -> self#latex_of_Target fmt ~target ~code
 
-    method latex_of_custom_text fmt s t = ()
+    method latex_of_custom_text _ _ _ = ()
 
     method latex_of_Target fmt ~target ~code =
       if String.lowercase_ascii target = "latex" then
@@ -519,7 +526,7 @@ class latex =
       match t.ty_parameters with
         [] -> ()
       | [(p,co,cn)] -> print_one (p, co, cn)
-      | l ->
+      | _ ->
           ps fmt "(";
           print_concat fmt ", " print_one t.ty_parameters;
           ps fmt ")"
@@ -528,11 +535,69 @@ class latex =
       self#latex_of_text fmt
         (self#text_of_class_params father c)
 
+
+    method entry_comment (fmt,flush) = function
+      | None -> []
+      | Some t ->
+          let s =
+            ps fmt "\\begin{ocamldoccomment}\n";
+            self#latex_of_info fmt (Some t);
+            ps fmt "\n\\end{ocamldoccomment}\n";
+            flush ()
+          in
+          [ Latex s]
+
+    (** record printing method *)
+    method latex_of_record ( (fmt,flush) as f) mod_name l =
+      p fmt "{";
+      let fields =
+        List.map (fun r ->
+            let s_field =
+              p fmt
+                "@[<h 6>  %s%s :@ %s ;"
+                (if r.rf_mutable then "mutable " else "")
+                r.rf_name
+                (self#normal_type mod_name r.rf_type);
+              flush ()
+            in
+            [ CodePre s_field ] @ (self#entry_comment f r.rf_text)
+          ) l in
+      List.flatten fields @ [ CodePre "}" ]
+
+    method latex_of_cstr_args ( (fmt,flush) as f) mod_name (args, ret) =
+      match args, ret with
+      | Cstr_tuple [], None -> []
+      | Cstr_tuple _ as l, None ->
+          p fmt " of@ %s"
+            (self#normal_cstr_args ~par:false mod_name l);
+          [CodePre (flush())]
+      | Cstr_tuple _ as l, Some r ->
+          p fmt " :@ %s@ %s@ %s"
+            (self#normal_cstr_args ~par:false mod_name l)
+            "->"
+            (self#normal_type mod_name r);
+          [CodePre (flush())]
+      | Cstr_record l, None ->
+          p fmt " of@ ";
+          self#latex_of_record f mod_name l
+      | Cstr_record r, Some res ->
+          let l =
+            p fmt " :@ ";
+            self#latex_of_record f mod_name r in
+          let l2 =
+            p fmt "@ %s@ %s" "->"
+              (self#normal_type mod_name res);
+            [CodePre (flush())] in
+          l @ l2
+
+
+
+
     (** Print LaTeX code for a type. *)
     method latex_of_type fmt t =
       let s_name = Name.simple t.ty_name in
       let text =
-        let (fmt2, flush2) = new_fmt () in
+        let ( (fmt2, flush2) as f) = new_fmt () in
         Odoc_info.reset_type_names () ;
         let mod_name = Name.father t.ty_name in
         Format.fprintf fmt2 "@[<h 2>type ";
@@ -558,24 +623,13 @@ class latex =
                 | _ -> ""
                 end
              | Type_variant _ -> "="^(if priv then " private" else "")
-             | Type_record _ -> "= "^(if priv then "private " else "")^"{"
+             | Type_record _ -> "= "^(if priv then "private " else "")
              | Type_open -> "= .."
             ) ;
           flush2 ()
         in
 
         let defs =
-          let entry_comment = function
-          | None -> []
-          | Some t ->
-              let s =
-                ps fmt2 "\\begin{ocamldoccomment}\n";
-                self#latex_of_info fmt2 (Some t);
-                ps fmt2 "\n\\end{ocamldoccomment}\n";
-                flush2 ()
-              in
-              [ Latex s]
-        in
           match t.ty_kind with
           | Type_abstract ->
              begin match t.ty_manifest with
@@ -589,7 +643,7 @@ class latex =
                        (self#normal_type mod_name r.of_type);
                      flush2 ()
                    in
-                   [ CodePre s_field ] @ (entry_comment r.of_text)
+                   [ CodePre s_field ] @ (self#entry_comment f r.of_text)
                  ) l
                in
                List.flatten fields @ [ CodePre ">" ]
@@ -598,58 +652,20 @@ class latex =
              end
           | Type_variant l ->
              let constructors =
-               List.map (fun constr ->
-                 let s_cons =
-                   p fmt2 "@[<h 6>  | %s" constr.vc_name ;
-                   begin match constr.vc_args, constr.vc_ret with
-                   | Cstr_tuple [], None -> ()
-                   | l, None ->
-                     p fmt2 " of@ %s"
-                       (self#normal_cstr_args ~par: false mod_name l)
-                   | Cstr_tuple [], Some r ->
-                     p fmt2 " :@ %s"
-                       (self#normal_type mod_name r)
-                   | l, Some r ->
-                     p fmt2 " :@ %s@ %s@ %s"
-                       (self#normal_cstr_args ~par: false mod_name l)
-                       "->"
-                       (self#normal_type mod_name r)
-                   end ;
-                   flush2 ()
-                 in
-                 [ CodePre s_cons ] @ (entry_comment constr.vc_text)
-               ) l
+               List.map (fun {vc_name; vc_args; vc_ret; vc_text} ->
+                   p fmt2 "@[<h 6>  | %s" vc_name ;
+                   let l = self#latex_of_cstr_args f mod_name (vc_args,vc_ret) in
+                   l @ (self#entry_comment f vc_text) ) l
              in
              List.flatten constructors
           | Type_record l ->
-             let fields =
-               List.map (fun r ->
-                 let s_field =
-                   p fmt2
-                     "@[<h 6>  %s%s :@ %s ;"
-                     (if r.rf_mutable then "mutable " else "")
-                     r.rf_name
-                     (self#normal_type mod_name r.rf_type);
-                   flush2 ()
-                 in
-                 [ CodePre s_field ] @ (entry_comment r.rf_text)
-               ) l
-             in
-             List.flatten fields @ [ CodePre "}" ]
+              self#latex_of_record f mod_name l
           | Type_open ->
              (* FIXME ? *)
              []
         in
         let defs2 = (CodePre s_type3) :: defs in
-        let rec iter = function
-            [] -> []
-          | [e] -> [e]
-          | (CodePre s1) :: (CodePre s2) :: q ->
-              iter ((CodePre (s1^"\n"^s2)) :: q)
-          | e :: q ->
-              e :: (iter q)
-        in
-        (iter defs2) @
+        (merge_codepre defs2) @
         [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @
         (self#text_of_info t.ty_info)
       in
@@ -659,7 +675,7 @@ class latex =
     (** Print LaTeX code for a type extension. *)
     method latex_of_type_extension mod_name fmt te =
       let text =
-        let (fmt2, flush2) = new_fmt () in
+        let (fmt2, flush2) as f = new_fmt () in
         Odoc_info.reset_type_names () ;
         Format.fprintf fmt2 "@[<h 2>type ";
         (
@@ -681,42 +697,22 @@ class latex =
              (List.map
                 (fun x ->
                    let father = Name.father x.xt_name in
-                   let s_cons =
-                     p fmt2 "@[<h 6>  | %s" (Name.simple x.xt_name);
-                     (
-                       match x.xt_args, x.xt_ret with
-                           Cstr_tuple [], None -> ()
-                         | l, None ->
-                             p fmt2 " %s@ %s"
-                               "of"
-                               (self#normal_cstr_args ~par: false father l)
-                         | Cstr_tuple [], Some r ->
-                             p fmt2 " %s@ %s"
-                               ":"
-                               (self#normal_type father r)
-                         | l, Some r ->
-                             p fmt2 " %s@ %s@ %s@ %s"
-                               ":"
-                               (self#normal_cstr_args ~par: false father l)
-                               "->"
-                               (self#normal_type father r)
-                     );
-                     (
-                       match x.xt_alias with
-                           None -> ()
-                         | Some xa ->
-                             p fmt2 " = %s"
-                               (
-                                 match xa.xa_xt with
-                                     None -> xa.xa_name
-                                   | Some x -> x.xt_name
-                               )
-                     );
-                     flush2 ()
-                    in
-                    [ Latex (self#make_label (self#extension_label x.xt_name));
-                      CodePre s_cons ] @
-                    (match x.xt_text with
+                   p fmt2 "@[<h 6>  | %s" (Name.simple x.xt_name);
+                   let l = self#latex_of_cstr_args f father (x.xt_args, x.xt_ret) in
+                   let c =
+                     begin match x.xt_alias with
+                     | None -> ()
+                     | Some xa ->
+                         p fmt2 " = %s"
+                           (
+                             match xa.xa_xt with
+                             | None -> xa.xa_name
+                             | Some x -> x.xt_name
+                           )
+                     end;
+                       [CodePre (flush2 ())] in
+                    Latex (self#make_label (self#extension_label x.xt_name)) :: l @ c
+                    @ (match x.xt_text with
                       None -> []
                     | Some t ->
                         let s =
@@ -733,25 +729,35 @@ class latex =
               )
         in
         let defs2 = (CodePre s_type3) :: defs in
-        let rec iter = function
-            [] -> []
-          | [e] -> [e]
-          | (CodePre s1) :: (CodePre s2) :: q ->
-              iter ((CodePre (s1^"\n"^s2)) :: q)
-          | e :: q ->
-              e :: (iter q)
-        in
-        (iter defs2) @
+        (merge_codepre defs2) @
         (self#text_of_info te.te_info)
       in
       self#latex_of_text fmt text
 
     (** Print LaTeX code for an exception. *)
     method latex_of_exception fmt e =
-      Odoc_info.reset_type_names () ;
-      self#latex_of_text fmt
-        ((Latex (self#make_label (self#exception_label e.ex_name))) ::
-         (to_text#text_of_exception e))
+      let text =
+        let (fmt2, flush2) as f = new_fmt() in
+        Odoc_info.reset_type_names () ;
+        let s_name = Name.simple e.ex_name in
+        let father = Name.father e.ex_name in
+        p fmt2 "@[<hov 2>exception %s" s_name;
+        let l = self#latex_of_cstr_args f father (e.ex_args, e.ex_ret) in
+        let s =
+          (match e.ex_alias with
+             None -> ()
+           | Some ea ->
+               Format.fprintf fmt " = %s"
+                 (
+                   match ea.ea_ex with
+                     None -> ea.ea_name
+                   | Some e -> e.ex_name
+                 )
+          ); [CodePre (flush2 ())] in
+       merge_codepre (l @ s ) @
+      [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]
+       @ (self#text_of_info e.ex_info) in
+      self#latex_of_text fmt text
 
     method latex_of_module_parameter fmt m_name p =
       self#latex_of_text fmt
@@ -814,7 +820,7 @@ class latex =
             [ Code " ";
               Code (self#relative_idents father s) ;
             ]
-      | Module_constraint (k, tk) ->
+      | Module_constraint (k, _tk) ->
           (* TODO: what should we print? *)
           self#latex_of_module_kind fmt father k
       | Module_typeof s ->
@@ -836,7 +842,7 @@ class latex =
           List.iter (self#latex_of_class_element fmt father) eles;
           self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
 
-      | Class_apply capp ->
+      | Class_apply _ ->
           (* TODO: print final type from typedtree *)
           self#latex_of_text fmt [Raw "class application not handled yet"]
 
@@ -990,7 +996,7 @@ class latex =
       self#latex_of_text fmt t;
       (
        match mt.mt_type, mt.mt_kind with
-       | Some mtyp, Some kind ->
+       | Some _, Some kind ->
            self#latex_of_text fmt [ Code " = " ];
            self#latex_of_text fmt [ Latex "\\end{ocamldoccode}\n" ];
            self#latex_for_module_type_label fmt mt;

diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index 79ee5b17d4e8586876aedc14420e5dd0d41db57f..a640d767a50ec11025908d933936e098c46016be 100644 (file)
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -15,7 +15,6 @@
 
 (** The man pages generator. *)
 open Odoc_info
-open Parameter
 open Value
 open Type
 open Extension
@@ -195,7 +194,7 @@ class virtual info =
         [] l
 
     (** Print the groff string to display an optional info structure. *)
-    method man_of_info ?(margin=0) b info_opt =
+    method man_of_info ?margin:(_ :int option) b info_opt =
         match info_opt with
         None -> ()
       | Some info ->
@@ -319,12 +318,12 @@ class man =
           bs b "\n.sp\n";
           self#man_of_text2 b t;
           bs b "\n.sp\n"
-      | Odoc_info.Title (n, l_opt, t) ->
+      | Odoc_info.Title (_, _, t) ->
           self#man_of_text2 b [Odoc_info.Code (Odoc_info.string_of_text t)]
       | Odoc_info.Latex _ ->
           (* don't care about LaTeX stuff in HTML. *)
           ()
-      | Odoc_info.Link (s, t) ->
+      | Odoc_info.Link (_, t) ->
           self#man_of_text2 b t
       | Odoc_info.Ref (name, _, _) ->
           self#man_of_text_element b
@@ -340,7 +339,7 @@ class man =
       | Odoc_info.Custom (s,t) -> self#man_of_custom_text b s t
       | Odoc_info.Target (target, code) -> self#man_of_Target b ~target ~code
 
-    method man_of_custom_text b s t = ()
+    method man_of_custom_text _ _ _ = ()
 
     method man_of_Target b ~target ~code =
       if String.lowercase_ascii target = "man" then bs b code else ()
@@ -385,23 +384,21 @@ class man =
 
     (** Print groff string to display a [Types.type_expr list].*)
     method man_of_cstr_args ?par b m_name sep l =
-      let s =
         match l with
         | Cstr_tuple l ->
-            Odoc_str.string_of_type_list ?par sep l
+            let s = Odoc_str.string_of_type_list ?par sep l in
+            let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
+            bs b "\n.B ";
+            bs b (self#relative_idents m_name s2);
+            bs b "\n"
         | Cstr_record l ->
-            Odoc_str.string_of_record l
-      in
-      let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
-      bs b "\n.B ";
-      bs b (self#relative_idents m_name s2);
-      bs b "\n"
+            self#man_of_record m_name b l
 
     (** Print groff string to display the parameters of a type.*)
     method man_of_type_expr_param_list b m_name t =
       match t.ty_parameters with
         [] -> ()
-      | l ->
+      | _ ->
           let s = Odoc_str.string_of_type_param_list t in
           let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
           bs b "\n.B ";
@@ -436,7 +433,7 @@ class man =
       (
         match te.te_type_parameters with
             [] -> ()
-          | l ->
+          | _ ->
               let s = Odoc_str.string_of_type_extension_param_list te in
               let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in
                 bs b "\n.B ";
@@ -506,7 +503,7 @@ class man =
       (
         match e.ex_args, e.ex_ret with
         | Cstr_tuple [], None -> ()
-        | l, None ->
+        | _, None ->
            bs b ".B of ";
            self#man_of_cstr_args
              ~par: false
@@ -538,17 +535,31 @@ class man =
       self#man_of_info b e.ex_info;
       bs b "\n.sp\n"
 
+
+    method field_comment b = function
+      | None -> ()
+      | Some t ->
+          bs b "  (* ";
+          self#man_of_info b (Some t);
+          bs b " *) "
+
+    (** Print groff string for a record type *)
+    method man_of_record father b l =
+          bs b "{";
+           List.iter (fun r ->
+             bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n ");
+             bs b (r.rf_name^" : ");
+             self#man_of_type_expr b father r.rf_type;
+             bs b ";";
+             self#field_comment b r.rf_text ;
+           ) l;
+          bs b "\n }\n"
+
+
     (** Print groff string for a type. *)
     method man_of_type b t =
       Odoc_info.reset_type_names () ;
       let father = Name.father t.ty_name in
-      let field_comment = function
-        | None -> ()
-        | Some t ->
-          bs b "  (* ";
-          self#man_of_info b (Some t);
-          bs b " *) "
-      in
       bs b ".I type ";
       self#man_of_type_expr_param_list b father t;
       (
@@ -570,7 +581,7 @@ class man =
             bs b (r.of_name^" : ");
             self#man_of_type_expr b father r.of_type;
             bs b ";";
-            field_comment r.of_text ;
+            self#field_comment b r.of_text ;
           ) l;
           bs b "\n >\n"
        | Some (Other typ) ->
@@ -632,15 +643,7 @@ class man =
       | Type_record l ->
           bs b "= ";
           if priv then bs b "private ";
-          bs b "{";
-           List.iter (fun r ->
-             bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n ");
-             bs b (r.rf_name^" : ");
-             self#man_of_type_expr b father r.rf_type;
-             bs b ";";
-             field_comment r.rf_text ;
-           ) l;
-          bs b "\n }\n"
+          self#man_of_record father b l
       | Type_open ->
           bs b "= ..";
           bs b "\n"
@@ -838,7 +841,7 @@ class man =
               bs b " * ";
               self#man_of_type_expr b modname ty)
             q
-       | Cstr_record _ -> bs b "{ ... }"
+       | Cstr_record r -> self#man_of_record c.vc_name b r
       );
       bs b "\n.sp\n";
       self#man_of_info b c.vc_text;
@@ -1170,7 +1173,7 @@ class man =
         | h :: q ->
             match acc2 with
               [] -> f acc1 [h] q
-            | h2 :: q2 ->
+            | h2 :: _ ->
                 if (name h) = (name h2) then
                   if List.mem h acc2 then
                     f acc1 acc2 q

diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
index 9a981e00715e0f9eea3913e01ade946ece05688e..4f1bbff7b6dae6792a144b2c9d41335cc38e6366 100644 (file)
--- a/ocamldoc/odoc_merge.ml
+++ b/ocamldoc/odoc_merge.ml
@@ -16,8 +16,6 @@
 (** Merge of information from [.ml] and [.mli] for a module.*)
 
 open Odoc_types
-
-module Name = Odoc_name
 open Odoc_parameter
 open Odoc_value
 open Odoc_type
@@ -113,7 +111,7 @@ let merge_info merge_options (m1 : info) (m2 : info) =
       [], [] -> []
     | l, []
     | [], l -> l
-    | l1, l2 ->
+    | l1, _ ->
         if List.mem Merge_before merge_options then
           merge_before_tags (m1.i_before @ m2.i_before)
         else

diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml
index a95c2a9ff2b7068e3dd074d99dec2bfaa4d90b99..cffffffde0ecb0078af0e1d6a60048cfc47a9537 100644 (file)
--- a/ocamldoc/odoc_misc.ml
+++ b/ocamldoc/odoc_misc.ml
@@ -68,7 +68,7 @@ let list_concat sep =
   let rec iter = function
       [] -> []
     | [h] -> [h]
-    | h :: q -> h :: sep :: q
+    | h :: q -> h :: sep :: iter q
   in
   iter
 
@@ -126,7 +126,7 @@ let rec string_of_text t =
       | Odoc_types.Latex s -> "{% "^s^" %}"
       | Odoc_types.Link (s, t) ->
           "["^s^"]"^(string_of_text t)
-      | Odoc_types.Ref (name, _, Some text) ->
+      | Odoc_types.Ref (_name, _, Some text) ->
           Printf.sprintf "[%s]" (string_of_text text)
       | Odoc_types.Ref (name, _, None) ->
           iter (Odoc_types.Code name)
@@ -258,7 +258,7 @@ let rec text_list_concat sep l =
       t @ (sep :: (text_list_concat sep q))
 
 let rec text_no_title_no_list t =
-  let rec iter t_ele =
+  let iter t_ele =
     match t_ele with
     | Odoc_types.Title (_,_,t) -> text_no_title_no_list t
     | Odoc_types.List l
@@ -316,7 +316,7 @@ let get_titles_in_text t =
     | Odoc_types.Left t
     | Odoc_types.Right t
     | Odoc_types.Emphasize t -> iter_text t
-    | Odoc_types.Latex s -> ()
+    | Odoc_types.Latex _ -> ()
     | Odoc_types.Link (_, t)
     | Odoc_types.Superscript t
     | Odoc_types.Subscript t  -> iter_text t

diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml
index 5c8cafbc56edff713c04d04568511cd624d57a91..f986a4fd9d1942bcbd9bbdad123036eb6ca97abb 100644 (file)
--- a/ocamldoc/odoc_module.ml
+++ b/ocamldoc/odoc_module.ml
@@ -246,7 +246,7 @@ let rec module_elements ?(trans=true) m =
             mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;
             mt_loc = Odoc_types.dummy_loc ;
           }
-    | Module_constraint (k, tk) ->
+    | Module_constraint (k, _tk) ->
         print_DEBUG "Odoc_module.module_element: Module_constraint";
       (* FIXME : use k or tk ? *)
         module_elements ~trans: trans
@@ -416,7 +416,7 @@ and module_parameters ?(trans=true) m =
           | Some (Modtype mt) -> module_type_parameters ~trans mt
         else
           []
-    | Module_constraint (k, tk) ->
+    | Module_constraint (_k, tk) ->
         module_type_parameters ~trans: trans
           { mt_name = "" ; mt_info = None ; mt_type = None ;
             mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ;

diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml
index f6d5b7e4c7767fe4aeaee76172af00d1233f92f0..df8a78605000c6319457f9c78d3cd246b7a31c34 100644 (file)
--- a/ocamldoc/odoc_name.ml
+++ b/ocamldoc/odoc_name.ml
@@ -146,7 +146,6 @@ let head_and_tail n =
     Not_found -> (n, "")
 
 let head n = fst (head_and_tail n)
-let tail n = snd (head_and_tail n)
 
 let depth name =
   try

diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll
index 56b94afd3f85e88e7ec0e1f7dfc07528dbcb826d..76debf1e29ca2b47c163522485990f76e9b1748b 100644 (file)
--- a/ocamldoc/odoc_ocamlhtml.mll
+++ b/ocamldoc/odoc_ocamlhtml.mll
@@ -38,22 +38,30 @@ let base_escape_strings = [
     (">", ">") ;
 ]
 
-let pre_escape_strings = [
+
+let prelike_escape_strings = [
   (" ", " ") ;
   ("\t", "        ") ;
-  ]
+  ("\n", "<br>\n")
+]
 
 
 let pre = ref false
 let fmt = ref Format.str_formatter
 
 (** Escape the strings which would clash with html syntax,
-   and some other strings if we want to get a PRE style.*)
+   and some other strings if we want to get a PRE style outside of
+   <pre> </pre>.*)
 let escape s =
+  let escape_strings =
+    if !pre then
+      base_escape_strings
+    else
+      base_escape_strings @ prelike_escape_strings in
   List.fold_left
     (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc)
     s
-    (if !pre then base_escape_strings @ pre_escape_strings else base_escape_strings)
+    escape_strings
 
 (** Escape the strings which would clash with html syntax. *)
 let escape_base s =
@@ -82,7 +90,7 @@ let create_hashtable size init =
 
 (** The function used to return html code for the given comment body. *)
 let html_of_comment = ref
-    (fun (s : string) -> "<b>Odoc_ocamlhtml.html_of_comment not initialized</b>")
+    (fun (_ : string) -> "<b>Odoc_ocamlhtml.html_of_comment not initialized</b>")
 
 let keyword_table =
   create_hashtable 149 [
@@ -423,7 +431,7 @@ and comment = parse
   | "*)"
       { match !comment_start_pos with
         | [] -> assert false
-        | [x] -> comment_start_pos := []
+        | [_] -> comment_start_pos := []
         | _ :: l ->
             store_comment_char '*';
             store_comment_char ')';

diff --git a/ocamldoc/odoc_parser.mly b/ocamldoc/odoc_parser.mly
index faa98c87da73459da8edb2b48a198504df5a1677..9c762b1d24e8a56037c8669399cc6e8a3da51ac6 100644 (file)
--- a/ocamldoc/odoc_parser.mly
+++ b/ocamldoc/odoc_parser.mly
@@ -14,7 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Odoc_types
 open Odoc_comments_global
 
 let uppercase = "[A-Z\192-\214\216-\222]"

diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
index 4ff1b29a15e1017873b499059be2a2140b8315fd..c07e7841f6b1eea6010ca787ab207102b8f30561 100644 (file)
--- a/ocamldoc/odoc_print.ml
+++ b/ocamldoc/odoc_print.ml
@@ -53,8 +53,8 @@ exception Use_code of string
 let simpl_module_type ?code t =
   let rec iter t =
     match t with
-      Types.Mty_ident p -> t
-    | Types.Mty_alias p -> t
+      Types.Mty_ident _
+    | Types.Mty_alias(_, _) -> t
     | Types.Mty_signature _ ->
         (
          match code with
@@ -79,7 +79,7 @@ let string_of_module_type ?code ?(complete=false) t =
 let simpl_class_type t =
   let rec iter t =
     match t with
-      Types.Cty_constr (p,texp_list,ct) -> t
+      Types.Cty_constr _ -> t
     | Types.Cty_signature cs ->
         (* we delete vals and methods in order to not print them when
            displaying the type *)

diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml
index 0975cdf1bd8223fca12cbb28f60845e88ac69743..7b5ba5dd494e7ce21d86b6820fe6401bc5614ac5 100644 (file)
--- a/ocamldoc/odoc_scan.ml
+++ b/ocamldoc/odoc_scan.ml
@@ -27,14 +27,13 @@ open Odoc_types
    overriding some methods.*)
 class scanner =
   object (self)
-  (** Scan of 'leaf elements'. *)
 
-    method scan_value (v : Odoc_value.t_value) = ()
+    method scan_value (_ : Odoc_value.t_value) = ()
 
-    method scan_type_pre (t : Odoc_type.t_type) = true
+    method scan_type_pre (_ : Odoc_type.t_type) = true
 
-    method scan_type_recfield t (f : Odoc_type.record_field) = ()
-    method scan_type_const t (f : Odoc_type.variant_constructor) = ()
+    method scan_type_recfield _t (_ : Odoc_type.record_field) = ()
+    method scan_type_const _t (_ : Odoc_type.variant_constructor) = ()
     method scan_type (t : Odoc_type.t_type) =
       if self#scan_type_pre t then
         match t.Odoc_type.ty_kind with
@@ -43,11 +42,11 @@ class scanner =
         | Odoc_type.Type_record l -> List.iter (self#scan_type_recfield t) l
         | Odoc_type.Type_open -> ()
 
-    method scan_extension_constructor (e : Odoc_extension.t_extension_constructor) = ()
-    method scan_exception (e : Odoc_exception.t_exception) = ()
-    method scan_attribute (a : Odoc_value.t_attribute) = ()
-    method scan_method (m : Odoc_value.t_method) = ()
-    method scan_included_module (im : Odoc_module.included_module) = ()
+    method scan_extension_constructor (_ : Odoc_extension.t_extension_constructor) = ()
+    method scan_exception (_ : Odoc_exception.t_exception) = ()
+    method scan_attribute (_ : Odoc_value.t_attribute) = ()
+    method scan_method (_ : Odoc_value.t_method) = ()
+    method scan_included_module (_ : Odoc_module.included_module) = ()
 
   (** Scan of a type extension *)
 
@@ -55,7 +54,7 @@ class scanner =
         private and info. This method is called before scanning the
         extensions's constructors.
         @return true if the extension's constructors must be scanned.*)
-    method scan_type_extension_pre (x: Odoc_extension.t_type_extension) = true
+    method scan_type_extension_pre (_: Odoc_extension.t_type_extension) = true
 
     (** This method scans the constructors of the given type extension. *)
     method scan_type_extension_constructors (x: Odoc_extension.t_type_extension) =
@@ -70,12 +69,12 @@ class scanner =
   (** Scan of a class. *)
 
     (** Scan of a comment inside a class. *)
-    method scan_class_comment (t : text) = ()
+    method scan_class_comment (_ : text) = ()
 
     (** Override this method to perform controls on the class comment
        and params. This method is called before scanning the class elements.
        @return true if the class elements must be scanned.*)
-    method scan_class_pre (c : Odoc_class.t_class) = true
+    method scan_class_pre (_ : Odoc_class.t_class) = true
 
     (** This method scan the elements of the given class.
        A VOIR : scan des classes heritees.*)
@@ -96,12 +95,12 @@ class scanner =
   (** Scan of a class type. *)
 
     (** Scan of a comment inside a class type. *)
-    method scan_class_type_comment (t : text) = ()
+    method scan_class_type_comment (_ : text) = ()
 
     (** Override this method to perform controls on the class type comment
        and form. This method is called before scanning the class type elements.
        @return true if the class type elements must be scanned.*)
-    method scan_class_type_pre (ct : Odoc_class.t_class_type) = true
+    method scan_class_type_pre (_ : Odoc_class.t_class_type) = true
 
     (** This method scan the elements of the given class type.
        A VOIR : scan des classes heritees.*)
@@ -122,12 +121,12 @@ class scanner =
   (** Scan of modules. *)
 
     (** Scan of a comment inside a module. *)
-    method scan_module_comment (t : text) = ()
+    method scan_module_comment (_ : text) = ()
 
     (** Override this method to perform controls on the module comment
        and form. This method is called before scanning the module elements.
        @return true if the module elements must be scanned.*)
-    method scan_module_pre (m : Odoc_module.t_module) = true
+    method scan_module_pre (_ : Odoc_module.t_module) = true
 
     (** This method scan the elements of the given module. *)
     method scan_module_elements m =
@@ -154,12 +153,12 @@ class scanner =
   (** Scan of module types. *)
 
     (** Scan of a comment inside a module type. *)
-    method scan_module_type_comment (t : text) = ()
+    method scan_module_type_comment (_ : text) = ()
 
     (** Override this method to perform controls on the module type comment
        and form. This method is called before scanning the module type elements.
        @return true if the module type elements must be scanned. *)
-    method scan_module_type_pre (mt : Odoc_module.t_module_type) = true
+    method scan_module_type_pre (_ : Odoc_module.t_module_type) = true
 
     (** This method scan the elements of the given module type. *)
     method scan_module_type_elements mt =

diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml
index 93dcbafe5ed424e8ba357c7bdbd7dedd256e7e34..530000bc5b76b132d19eabac9b661401a17ad3d3 100644 (file)
--- a/ocamldoc/odoc_search.ml
+++ b/ocamldoc/odoc_search.ml
@@ -15,8 +15,6 @@
 
 (** Research of elements through modules. *)
 
-module Name = Odoc_name
-open Odoc_parameter
 open Odoc_value
 open Odoc_type
 open Odoc_extension
@@ -93,7 +91,7 @@ module Search =
       | T.Module_list _
       | T.Index_list -> []
       | T.Target _ -> []
-      | T.Title (n, l_opt, t) ->
+      | T.Title (_, l_opt, t) ->
           (match l_opt with
             None -> []
           | Some s -> search_section t (Name.concat root s) v) @

diff --git a/ocamldoc/odoc_see_lexer.mll b/ocamldoc/odoc_see_lexer.mll
index b676154d85501ea9f1c7e4e271c028bc2b65335f..1962d50dc92b3ddae13b2709accba6856aca8382 100644 (file)
--- a/ocamldoc/odoc_see_lexer.mll
+++ b/ocamldoc/odoc_see_lexer.mll
@@ -18,7 +18,6 @@ let print_DEBUG2 s = print_string s ; print_newline ()
 
 (** the lexer for special comments. *)
 
-open Lexing
 open Odoc_parser
 
 let buf = Buffer.create 32

diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 8859ca2edd68caa8d90d1d7402b60a0b035dd905..ff1e9a57b4b8baef83e7a0118e69ca7ab5f2d2d8 100644 (file)
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -18,12 +18,9 @@
 open Misc
 open Asttypes
 open Types
-open Typedtree
-open Path
 
 let print_DEBUG s = print_string s ; print_newline ();;
 
-module Name = Odoc_name
 open Odoc_parameter
 open Odoc_value
 open Odoc_type
@@ -43,7 +40,6 @@ module Signature_search =
       | C of string
       | CT of string
       | X of string
-      | P of string
 
     type tab = (ele, Types.signature_item) Hashtbl.t
 
@@ -96,7 +92,7 @@ module Signature_search =
 
     let search_module table name =
       match Hashtbl.find table (M name) with
-      | (Types.Sig_module (ident, md, _)) -> md.Types.md_type
+      | (Types.Sig_module (_ident, md, _)) -> md.Types.md_type
       | _ -> assert false
 
     let search_module_type table name =
@@ -131,6 +127,7 @@ module Analyser =
   struct
     (** This variable is used to load a file as a string and retrieve characters from it.*)
     let file = ref ""
+
     (** The name of the analysed file. *)
     let file_name = ref ""
 
@@ -144,6 +141,26 @@ module Analyser =
         Invalid_argument _ ->
           ""
 
+    let just_after_special start stop =
+      let s = get_string_of_file start stop in
+      My_ir.just_after_special !file_name s
+
+    (** Helper functions for extracting location*)
+    module Loc = struct
+      let gen proj =
+        (fun ct -> (proj ct).Location.loc_start.Lexing.pos_cnum),
+        (fun ct -> (proj ct).Location.loc_end.Lexing.pos_cnum)
+    let ptyp' ct = ct.Parsetree.ptyp_loc
+    let pcd' pcd = pcd.Parsetree.pcd_loc
+    let loc' loc = loc
+    let psig' p = p.Parsetree.psig_loc
+
+    let start, end_ = gen loc'
+    let ptyp_start, ptyp_end = gen ptyp'
+    let pcd_start, pcd_end = gen pcd'
+    let psig_start, psig_end = gen psig'
+    end
+
     (** This function loads the given file in the file global variable,
        and sets file_name.*)
     let prepare_file f input_f =
@@ -170,6 +187,90 @@ module Analyser =
 
     let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options
 
+    (** Module for extracting documentation comments for record from different
+        tree types *)
+    module Record = struct
+
+      (** A structure to abstract over the tree type *)
+      type ('a,'b,'c) projector = {
+        name:'a -> string;
+        inline_record: 'b -> 'c option;
+        inline_end: 'b -> int;
+        start:'a -> int;
+        end_: 'a -> int }
+
+    (** A function to extract documentation from a list of label declarations *)
+    let doc p pos_end ld =
+      let rec f = function
+        | [] -> []
+        | ld :: [] ->
+            let name = p.name ld in
+            let pos = p.end_ ld in
+            let (_,comment_opt) =  just_after_special pos pos_end in
+            [name, comment_opt]
+        | ld  :: ele2 :: q ->
+            let pos = p.end_ ld in
+            let pos2 = p.start ele2 in
+            let name = p.name ld in
+            let (_,comment_opt) = just_after_special pos pos2 in
+            (name, comment_opt) :: (f (ele2 :: q))
+      in
+      f ld
+
+    let inline_doc p cstr =
+      match p.inline_record cstr with
+      | None -> []
+      | Some r ->
+          doc p (p.inline_end cstr) r
+
+    (** The three tree types used in the rest of the source: *)
+
+    let parsetree =
+      let open Parsetree in
+      { name = (fun ld -> ld.pld_name.txt );
+        start = (fun ld -> Loc.ptyp_start ld.pld_type);
+        end_ =  (fun ld -> Loc.ptyp_end ld.pld_type);
+        inline_record = begin
+          fun c -> match c.pcd_args with
+            | Pcstr_tuple _ -> None
+            | Pcstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.pcd_loc)
+      }
+
+    let types =
+      let open Types in
+      { name = (fun ld -> ld.ld_id.Ident.name );
+        start = (fun ld -> Loc.start ld.ld_loc);
+        end_ =  (fun ld -> Loc.start ld.ld_loc);
+        (* Beware, Loc.start is correct in the code above:
+           type_expr's do not hold location information, and ld.ld_loc
+           ends after the documentation comment, sow e use Loc.start as
+           the least problematic approximation for end_. *)
+        inline_record = begin
+          fun c -> match c.cd_args with
+            | Cstr_tuple _ -> None
+            | Cstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.cd_loc)
+      }
+
+    let typedtree =
+      let open Typedtree in
+      { name = (fun ld -> ld.ld_id.Ident.name );
+        start = (fun ld -> Loc.start ld.ld_type.ctyp_loc);
+        end_ =  (fun ld -> Loc.end_ ld.ld_type.ctyp_loc);
+        inline_record = begin
+          fun c -> match c.cd_args with
+            | Cstr_tuple _ -> None
+            | Cstr_record r -> Some r
+        end;
+        inline_end = (fun c -> Loc.end_ c.cd_loc)
+      }
+
+
+    end
+
     let name_comment_from_type_decl pos_end pos_limit ty_decl =
       match ty_decl.Parsetree.ptype_kind with
       | Parsetree.Ptype_abstract ->
@@ -186,15 +287,13 @@ module Analyser =
                 assert false
 
               | (name, _atts, ct) :: [] ->
-                let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
-                let s = get_string_of_file pos pos_end in
-                let (_,comment_opt) =  My_ir.just_after_special !file_name s in
+                let pos = Loc.ptyp_end ct in
+                let (_,comment_opt) = just_after_special pos pos_end in
                 [name, comment_opt]
-              | (name, _atts, ct) :: ((name2, _atts2, ct2) as ele2) :: q ->
-                let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
-                let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
-                let s = get_string_of_file pos pos2 in
-                let (_,comment_opt) =  My_ir.just_after_special !file_name s in
+              | (name, _atts, ct) :: ((_name2, _atts2, ct2) as ele2) :: q ->
+                let pos = Loc.ptyp_end ct in
+                let pos2 = Loc.ptyp_start ct2 in
+                let (_,comment_opt) = just_after_special pos pos2 in
                 (name, comment_opt) :: (f (ele2 :: q))
             in
             let is_named_field field =
@@ -215,40 +314,22 @@ module Analyser =
               [] ->
                 (0, acc)
             | pcd :: [] ->
-                let s = get_string_of_file
-                    pcd.pcd_loc.Location.loc_end.Lexing.pos_cnum
-                    pos_limit
-                in
-                let (len, comment_opt) =  My_ir.just_after_special !file_name s in
-                (len, acc @ [ (pcd.pcd_name.txt, comment_opt) ])
+                let acc = Record.(inline_doc parsetree) pcd @ acc in
+                let (len, comment_opt) =
+                  just_after_special (Loc.pcd_end pcd) pos_limit in
+                (len, List.rev @@ (pcd.pcd_name.txt, comment_opt):: acc )
             | pcd :: (pcd2 :: _ as q) ->
-                (* TODO: support annotations on fields for inline records *)
-                let pos_end_first = pcd.pcd_loc.Location.loc_end.Lexing.pos_cnum in
-                let pos_start_second = pcd2.pcd_loc.Location.loc_start.Lexing.pos_cnum in
-                let s = get_string_of_file pos_end_first pos_start_second in
-                let (_,comment_opt) = My_ir.just_after_special !file_name  s in
-                f (acc @ [pcd.pcd_name.txt, comment_opt]) q
+                let acc = Record.(inline_doc parsetree) pcd @ acc in
+                let pos_end_first = Loc.pcd_end pcd in
+                let pos_start_second = Loc.pcd_start pcd2 in
+                let (_,comment_opt) =
+                  just_after_special pos_end_first pos_start_second in
+                f ((pcd.pcd_name.txt, comment_opt)::acc) q
           in
           f [] cons_core_type_list_list
 
-      | Parsetree.Ptype_record name_mutable_type_list (* of (string * mutable_flag * core_type) list*) ->
-          let open Parsetree in
-          let rec f = function
-              [] ->
-                []
-            | {pld_name=name; pld_type=ct} :: [] ->
-                let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
-                let s = get_string_of_file pos pos_end in
-                let (_,comment_opt) =  My_ir.just_after_special !file_name s in
-                [name.txt, comment_opt]
-            | {pld_name=name; pld_type=ct} :: ({pld_name=name2; pld_type=ct2} as ele2) :: q ->
-                let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
-                let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
-                let s = get_string_of_file pos pos2 in
-                let (_,comment_opt) =  My_ir.just_after_special !file_name s in
-                (name.txt, comment_opt) :: (f (ele2 :: q))
-          in
-          (0, f name_mutable_type_list)
+      | Parsetree.Ptype_record label_declaration_list ->
+          (0, Record.(doc parsetree) pos_end label_declaration_list)
       | Parsetree.Ptype_open ->
           (0, [])
 
@@ -298,7 +379,8 @@ module Analyser =
             let vc_args =
               match cd_args with
               | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l)
-              | Cstr_record l -> Cstr_record (List.map (get_field env []) l)
+              | Cstr_record l ->
+                  Cstr_record (List.map (get_field env name_comment_list) l)
             in
             {
               vc_name = constructor_name ;
@@ -316,6 +398,21 @@ module Analyser =
           Odoc_type.Type_open
 
 
+    let get_cstr_args env pos_end =
+      let tuple ct = Odoc_env.subst_type env ct.Typedtree.ctyp_type in
+      let record comments
+          { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
+        get_field env comments @@
+        {Types.ld_id; ld_mutable; ld_type=ld_type.Typedtree.ctyp_type;
+         ld_loc; ld_attributes } in
+      let open Typedtree in
+      function
+      | Cstr_tuple l ->
+          Odoc_type.Cstr_tuple (List.map tuple l)
+      | Cstr_record l ->
+          let comments = Record.(doc typedtree) pos_end l in
+          Odoc_type.Cstr_record (List.map (record comments) l)
+
     let erased_names_of_constraints constraints acc =
       List.fold_right (fun constraint_ acc ->
         match constraint_ with
@@ -365,9 +462,9 @@ module Analyser =
               Parsetree.Pctf_val (_, _, _, _)
             | Parsetree.Pctf_method (_, _, _, _)
             | Parsetree.Pctf_constraint (_, _)
-            | Parsetree.Pctf_attribute _ -> loc.Location.loc_start.Lexing.pos_cnum
+            | Parsetree.Pctf_attribute _ -> Loc.start loc
             | Parsetree.Pctf_inherit class_type ->
-                class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum
+                Loc.start class_type.Parsetree.pcty_loc
             | Parsetree.Pctf_extension _ -> assert false
       in
       let get_method name comment_opt private_flag loc q =
@@ -395,7 +492,7 @@ module Analyser =
           }
         in
         let pos_limit2 = get_pos_limit2 q in
-        let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
+        let pos_end = Loc.end_ loc in
         let (maybe_more, info_after_opt) =
           My_ir.just_after_special
             !file_name
@@ -430,7 +527,8 @@ module Analyser =
 
         | Parsetree.Pctf_val (name, mutable_flag, virtual_flag, _) ->
             (* of (string * mutable_flag * core_type option * Location.t)*)
-            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+            let (comment_opt, eles_comments) = get_comments_in_class last_pos
+                (Loc.start loc) in
             let complete_name = Name.concat current_class_name name in
             let typ =
               try Signature_search.search_attribute_type name class_signature
@@ -455,7 +553,7 @@ module Analyser =
               }
             in
             let pos_limit2 = get_pos_limit2 q in
-            let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
+            let pos_end = Loc.end_ loc in
             let (maybe_more, info_after_opt) =
               My_ir.just_after_special
                 !file_name
@@ -467,34 +565,33 @@ module Analyser =
 
         | Parsetree.Pctf_method (name, private_flag, virtual_flag, _) ->
             (* of (string * private_flag * virtual_flag * core_type) *)
-            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+            let (comment_opt, eles_comments) =
+              get_comments_in_class last_pos (Loc.start  loc) in
             let (met, maybe_more) = get_method name comment_opt private_flag loc q in
             let met2 =
               match virtual_flag with
               | Concrete -> met
               | Virtual -> { met with met_virtual = true }
             in
-            let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in
+            let (inher_l, eles) = f (Loc.end_ loc + maybe_more) q in
             (inher_l, eles_comments @ ((Class_method met2) :: eles))
 
         | (Parsetree.Pctf_constraint (_, _)) ->
             (* of (core_type * core_type) *)
             (* FIXME: this corresponds to constraints, isn't it? We don't keep them for now *)
-            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-            let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in
+            let (_comment_opt, eles_comments) = get_comments_in_class last_pos
+                (Loc.start loc) in
+            let (inher_l, eles) = f (Loc.end_ loc) q in
             (inher_l, eles_comments @ eles)
 
         | Parsetree.Pctf_inherit class_type ->
             let loc = class_type.Parsetree.pcty_loc in
             let (comment_opt, eles_comments) =
-              get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum
-            in
+              get_comments_in_class last_pos (Loc.start loc) in
             let pos_limit2 = get_pos_limit2 q in
-            let pos_end = loc.Location.loc_end.Lexing.pos_cnum in
+            let pos_end = Loc.end_ loc in
             let (maybe_more, info_after_opt) =
-              My_ir.just_after_special
-                !file_name
-                (get_string_of_file pos_end pos_limit2)
+             just_after_special pos_end pos_limit2
             in
             let comment_opt2 = merge_infos comment_opt info_after_opt in
             let text_opt = match comment_opt2 with None -> None | Some i -> i.Odoc_types.i_desc in
@@ -522,8 +619,9 @@ module Analyser =
             let (inher_l, eles) = f (pos_end + maybe_more) q in
             (inh :: inher_l , eles_comments @ eles)
         | Parsetree.Pctf_attribute _ ->
-            let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-            let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in
+            let (_comment_opt, eles_comments) =
+              get_comments_in_class last_pos (Loc.start loc) in
+            let (inher_l, eles) = f (Loc.end_ loc) q in
             (inher_l, eles_comments @ eles)
 
         | Parsetree.Pctf_extension _ -> assert false
@@ -554,9 +652,8 @@ module Analyser =
             acc_eles @ ele_comments
 
         | ele :: q ->
-            let (assoc_com, ele_comments) =  get_comments_in_module
-                last_pos
-                ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
+            let (assoc_com, ele_comments) =
+              get_comments_in_module last_pos (Loc.psig_start ele)
             in
             let (maybe_more, new_env, elements) = analyse_signature_item_desc
                 acc_env
@@ -564,17 +661,16 @@ module Analyser =
                 table
                 current_module_name
                 ele.Parsetree.psig_loc
-                ele.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
-                ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum
+                (Loc.psig_start ele)
+                (Loc.psig_end ele)
                 (match q with
                   [] -> pos_limit
-                | ele2 :: _ -> ele2.Parsetree.psig_loc.Location.loc_start.Lexing.pos_cnum
+                | ele2 :: _ -> Loc.psig_start ele2
                 )
                 assoc_com
                 ele.Parsetree.psig_desc
             in
-            let new_pos =
-              ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum + maybe_more
+            let new_pos = Loc.psig_end ele + maybe_more
               (* for the comments of constructors in types,
                  which are after the constructor definition and can
                  go beyond ele.Parsetree.psig_loc.Location.loc_end.Lexing.pos_cnum *)
@@ -588,7 +684,7 @@ module Analyser =
 
     (** Analyse the given signature_item_desc to create the corresponding module element
        (with the given attached comment).*)
-    and analyse_signature_item_desc env signat table current_module_name
+    and analyse_signature_item_desc env _signat table current_module_name
         sig_item_loc pos_start_ele pos_end_ele pos_limit comment_opt sig_item_desc =
         match sig_item_desc with
           Parsetree.Psig_value value_desc ->
@@ -639,6 +735,7 @@ module Analyser =
               (env, [], None)
               tyext.Parsetree.ptyext_constructors
           in
+          let types_ext_list = List.rev types_ext_list in
           let ty_path, ty_params, priv =
             match last_ext with
               None -> assert false
@@ -667,11 +764,14 @@ module Analyser =
             match types_ext_list with
               [] -> (maybe_more, List.rev exts_acc)
             | (name, types_ext) :: q ->
-              let ext_loc_end =  types_ext.Types.ext_loc.Location.loc_end.Lexing.pos_cnum in
+              let ext_loc_end =  Loc.end_ types_ext.Types.ext_loc in
               let xt_args =
                 match types_ext.ext_args with
-                | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type new_env) l)
-                | Cstr_record l -> Cstr_record (List.map (get_field new_env []) l)
+                | Cstr_tuple l ->
+                    Cstr_tuple (List.map (Odoc_env.subst_type new_env) l)
+                | Cstr_record l ->
+                    let docs = Record.(doc types ext_loc_end) l in
+                    Cstr_record (List.map (get_field new_env docs) l)
               in
               let new_x =
                 {
@@ -687,19 +787,17 @@ module Analyser =
               let pos_limit2 =
                 match q with
                   [] -> pos_limit
-                | (_, next) :: _ -> next.Types.ext_loc.Location.loc_start.Lexing.pos_cnum
+                | (_, next) :: _ -> Loc.start (next.Types.ext_loc)
               in
-              let s = get_string_of_file ext_loc_end pos_limit2 in
-              let (maybe_more, comment_opt) =  My_ir.just_after_special !file_name s in
+              let (maybe_more, comment_opt) =
+                just_after_special ext_loc_end pos_limit2 in
                 new_x.xt_text <- comment_opt;
                 analyse_extension_constructors maybe_more (new_x :: exts_acc) q
           in
           let (maybe_more, exts) = analyse_extension_constructors 0 [] types_ext_list in
             new_te.te_constructors <- exts;
             let (maybe_more2, info_after_opt) =
-              My_ir.just_after_special
-                !file_name
-                (get_string_of_file (pos_end_ele + maybe_more) pos_limit)
+              just_after_special (pos_end_ele + maybe_more) pos_limit
             in
               new_te.te_info <- merge_infos new_te.te_info info_after_opt ;
               (maybe_more + maybe_more2, new_env, [ Element_type_extension new_te ])
@@ -712,9 +810,12 @@ module Analyser =
                 raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt))
             in
             let ex_args =
+              let pos_end = Loc.end_ types_ext.ext_loc in
               match types_ext.ext_args with
               | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l)
-              | Cstr_record l -> Cstr_record (List.map (get_field env []) l)
+              | Cstr_record l ->
+                  let docs = Record.(doc types) pos_end l in
+                  Cstr_record (List.map (get_field env docs) l)
             in
             let e =
               {
@@ -769,16 +870,16 @@ module Analyser =
                     else
                       get_comments_in_module
                         last_pos
-                        type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
+                        (Loc.start type_decl.Parsetree.ptype_loc)
                   in
                   let pos_limit2 =
                     match q with
                       [] -> pos_limit
-                    | td :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
+                    | td :: _ -> Loc.start (td.Parsetree.ptype_loc)
                   in
                   let (maybe_more, name_comment_list) =
                     name_comment_from_type_decl
-                      type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum
+                      (Loc.end_ type_decl.Parsetree.ptype_loc)
                       pos_limit2
                       type_decl
                   in
@@ -807,8 +908,9 @@ module Analyser =
                   in
                   (* get the type kind with the associated comments *)
                   let type_kind = get_type_kind env name_comment_list sig_type_decl.Types.type_kind in
-                  let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
-                  let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + maybe_more in
+                  let loc_start = Loc.start type_decl.Parsetree.ptype_loc in
+                  let new_end = Loc.end_ type_decl.Parsetree.ptype_loc
+                                + maybe_more in
                   (* associate the comments to each constructor and build the [Type.t_type] *)
                   let new_type =
                     {
@@ -876,8 +978,8 @@ module Analyser =
             let code_intf =
               if !Odoc_global.keep_code then
                 let loc = module_type.Parsetree.pmty_loc in
-                let st = loc.Location.loc_start.Lexing.pos_cnum in
-                let en = loc.Location.loc_end.Lexing.pos_cnum in
+                let st = Loc.start loc in
+                let en = Loc.end_ loc in
                 Some (get_string_of_file st en)
               else
                 None
@@ -942,8 +1044,8 @@ module Analyser =
               | {Parsetree.pmd_name=name; pmd_type=modtype} :: q ->
                   let complete_name = Name.concat current_module_name name.txt in
                   let loc = modtype.Parsetree.pmty_loc in
-                  let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-                  let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
+                  let loc_start = Loc.start loc in
+                  let loc_end = Loc.end_ loc in
                   let (assoc_com, ele_comments) =
                     if first then
                       (comment_opt, [])
@@ -955,7 +1057,7 @@ module Analyser =
                   let pos_limit2 =
                     match q with
                       [] -> pos_limit
-                    | _ :: _ -> loc.Location.loc_start.Lexing.pos_cnum
+                    | _ :: _ -> Loc.start loc
                   in
                   (* get the information for the module in the signature *)
                   let sig_module_type =
@@ -967,8 +1069,8 @@ module Analyser =
                   let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in
                   let code_intf =
                     if !Odoc_global.keep_code then
-                      let st = loc.Location.loc_start.Lexing.pos_cnum in
-                      let en = loc.Location.loc_end.Lexing.pos_cnum in
+                      let st = Loc.start loc in
+                      let en = Loc.end_ loc in
                       Some (get_string_of_file st en)
                     else
                       None
@@ -1098,14 +1200,13 @@ module Analyser =
                     else
                       get_comments_in_module
                         last_pos
-                        class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                        (Loc.start class_desc.Parsetree.pci_loc)
                   in
-                  let pos_end = class_desc.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
+                  let pos_end = Loc.end_ class_desc.Parsetree.pci_loc in
                   let pos_limit2 =
                     match q with
                       [] -> pos_limit
-                    | cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
-                  in
+                    | cd :: _ -> Loc.start cd.Parsetree.pci_loc in
                   let name = class_desc.Parsetree.pci_name in
                   let complete_name = Name.concat current_module_name name.txt in
                   let sig_class_decl =
@@ -1118,7 +1219,7 @@ module Analyser =
                     analyse_class_kind
                      new_env
                      complete_name
-                     class_desc.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                     (Loc.start class_desc.Parsetree.pci_loc)
                      class_desc.Parsetree.pci_expr
                      sig_class_type
                  in
@@ -1135,10 +1236,7 @@ module Analyser =
                    }
                  in
                  let (maybe_more, info_after_opt) =
-                   My_ir.just_after_special
-                     !file_name
-                     (get_string_of_file pos_end pos_limit2)
-                 in
+                   just_after_special pos_end pos_limit2 in
                  new_class.cl_info <- merge_infos new_class.cl_info info_after_opt ;
                  Odoc_class.class_update_parameters_text new_class ;
                  let (new_maybe_more, eles) =
@@ -1174,13 +1272,13 @@ module Analyser =
                     else
                       get_comments_in_module
                         last_pos
-                        ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                        (Loc.start ct_decl.Parsetree.pci_loc)
                   in
-                  let pos_end = ct_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
+                  let pos_end = Loc.end_ ct_decl.Parsetree.pci_loc in
                   let pos_limit2 =
                     match q with
                       [] -> pos_limit
-                    | ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                    | ct_decl2 :: _ -> Loc.start ct_decl2.Parsetree.pci_loc
                   in
                   let name = ct_decl.Parsetree.pci_name in
                   let complete_name = Name.concat current_module_name name.txt in
@@ -1193,7 +1291,7 @@ module Analyser =
                   let kind = analyse_class_type_kind
                       new_env
                       complete_name
-                      ct_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+                      (Loc.start ct_decl.Parsetree.pci_loc)
                       ct_decl.Parsetree.pci_expr
                       sig_class_type
                   in
@@ -1209,9 +1307,7 @@ module Analyser =
                     }
                   in
                   let (maybe_more, info_after_opt) =
-                    My_ir.just_after_special
-                      !file_name
-                      (get_string_of_file pos_end pos_limit2)
+                    just_after_special pos_end pos_limit2
                   in
                   ct.clt_info <- merge_infos ct.clt_info info_after_opt ;
                   let (new_maybe_more, eles) =
@@ -1245,7 +1341,7 @@ module Analyser =
       | Parsetree.Pmty_alias longident ->
           let name =
             match sig_module_type with
-              Types.Mty_alias path -> Name.from_path path
+              Types.Mty_alias(_, path) -> Name.from_path path
             | _ -> Name.from_longident longident.txt
           in
           (* Wrong naming... *)
@@ -1258,8 +1354,8 @@ module Analyser =
            (* we must have a signature in the module type *)
            match sig_module_type with
              Types.Mty_signature signat ->
-               let pos_start = module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
-               let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+               let pos_start = Loc.start module_type.Parsetree.pmty_loc in
+               let pos_end = Loc.end_ module_type.Parsetree.pmty_loc in
                let elements = analyse_parsetree env signat current_module_name pos_start pos_end ast in
                Module_type_struct elements
            | _ ->
@@ -1270,8 +1366,8 @@ module Analyser =
           (
            let loc = match pmodule_type2 with None -> Location.none
                      | Some pmty -> pmty.Parsetree.pmty_loc in
-           let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-           let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
+           let loc_start = Loc.start loc in
+           let loc_end = Loc.end_ loc in
            let mp_type_code = get_string_of_file loc_start loc_end in
            print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
            match sig_module_type with
@@ -1307,8 +1403,8 @@ module Analyser =
       | Parsetree.Pmty_with (module_type2, constraints) ->
           (* of module_type * (Longident.t * with_constraint) list *)
           (
-           let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
-           let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+           let loc_start = Loc.end_ module_type2.Parsetree.pmty_loc in
+           let loc_end = Loc.end_ module_type.Parsetree.pmty_loc in
            let s = get_string_of_file loc_start loc_end in
            let erased = erased_names_of_constraints constraints erased in
            let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in
@@ -1317,8 +1413,8 @@ module Analyser =
           )
 
       | Parsetree.Pmty_typeof module_expr ->
-          let loc_start = module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
-          let loc_end = module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
+          let loc_start = Loc.start module_expr.Parsetree.pmod_loc in
+          let loc_end = Loc.end_ module_expr.Parsetree.pmod_loc in
           let s = get_string_of_file loc_start loc_end in
           Module_type_typeof s
 
@@ -1328,13 +1424,13 @@ module Analyser =
     and analyse_module_kind
         ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type =
       match module_type.Parsetree.pmty_desc with
-      | Parsetree.Pmty_ident longident ->
+      | Parsetree.Pmty_ident _longident ->
           let k = analyse_module_type_kind env current_module_name module_type sig_module_type in
           Module_with ( k, "" )
-      | Parsetree.Pmty_alias longident ->
+      | Parsetree.Pmty_alias _longident ->
           begin
             match sig_module_type with
-              Types.Mty_alias path ->
+              Types.Mty_alias(_, path) ->
                 let alias_name = Odoc_env.full_module_name env (Name.from_path path) in
                 let ma = { ma_name = alias_name ; ma_module = None } in
                 Module_alias ma
@@ -1351,8 +1447,8 @@ module Analyser =
                     env
                     signat
                     current_module_name
-                    module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum
-                    module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum
+                    (Loc.start module_type.Parsetree.pmty_loc)
+                    (Loc.end_ module_type.Parsetree.pmty_loc)
                     signature
                  )
            | _ ->
@@ -1365,8 +1461,8 @@ module Analyser =
              Types.Mty_functor (ident, param_module_type, body_module_type) ->
                let loc = match pmodule_type2 with None -> Location.none
                      | Some pmty -> pmty.Parsetree.pmty_loc in
-               let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
-               let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
+               let loc_start = Loc.start loc in
+               let loc_end = Loc.end_ loc in
                let mp_type_code = get_string_of_file loc_start loc_end in
                print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
                let mp_kind =
@@ -1398,16 +1494,16 @@ module Analyser =
       | Parsetree.Pmty_with (module_type2, constraints) ->
           (*of module_type * (Longident.t * with_constraint) list*)
           (
-           let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
-           let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
+           let loc_start = Loc.end_ module_type2.Parsetree.pmty_loc in
+           let loc_end = Loc.end_ module_type.Parsetree.pmty_loc in
            let s = get_string_of_file loc_start loc_end in
            let erased = erased_names_of_constraints constraints erased in
            let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in
            Module_with (k, s)
           )
       | Parsetree.Pmty_typeof module_expr ->
-          let loc_start = module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
-          let loc_end = module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
+          let loc_start = Loc.start module_expr.Parsetree.pmod_loc in
+          let loc_end = Loc.end_ module_expr.Parsetree.pmod_loc in
           let s = get_string_of_file loc_start loc_end in
           Module_typeof s
 
@@ -1437,7 +1533,7 @@ module Analyser =
           (* we get the elements of the class in class_type_field_list *)
           let (inher_l, ele) = analyse_class_elements env current_class_name
               last_pos
-              parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum
+              (Loc.end_ parse_class_type.Parsetree.pcty_loc)
               class_type_field_list
               class_signature
           in
@@ -1485,13 +1581,13 @@ module Analyser =
           (* we get the elements of the class in class_type_field_list *)
           let (inher_l, ele) = analyse_class_elements env current_class_name
               last_pos
-              parse_class_type.Parsetree.pcty_loc.Location.loc_end.Lexing.pos_cnum
+              (Loc.end_ parse_class_type.Parsetree.pcty_loc)
               class_type_field_list
               class_signature
           in
           Class_signature (inher_l, ele)
 
-      | (Parsetree.Pcty_arrow (parse_label, _, pclass_type), Types.Cty_arrow (label, type_expr, class_type)) ->
+      | (Parsetree.Pcty_arrow _, Types.Cty_arrow _) ->
           raise (Failure "analyse_class_type_kind : Parsetree.Pcty_arrow (...) with Types.Cty_arrow (...)")
 (*
       | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *),

diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli
index 65e7b373d82d7d7c705bcd81b241315fd2e93e6b..b53189873d69bc31d3917634dfe5b35cd668c2fe 100644 (file)
--- a/ocamldoc/odoc_sig.mli
+++ b/ocamldoc/odoc_sig.mli
@@ -157,6 +157,13 @@ module Analyser :
           Odoc_env.env -> (string * Odoc_types.info option) list ->
             Types.type_kind -> Odoc_type.type_kind
 
+      (** This function converts a [Types.constructor_arguments] into a
+          [Odoc_type.constructor_args], by associating the comment found
+          in the parsetree of each inner record field, if any.*)
+      val get_cstr_args:
+        Odoc_env.env -> int -> Typedtree.constructor_arguments ->
+        Odoc_type.constructor_args
+
       (** This function merge two optional info structures. *)
       val merge_infos :
           Odoc_types.info option -> Odoc_types.info option ->

diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
index bfaea763af01d9a62b57b4848a6c48ac917f1efd..44d03db11094d12219991e4fd7d1d06cc9e83251 100644 (file)
--- a/ocamldoc/odoc_str.ml
+++ b/ocamldoc/odoc_str.ml
@@ -298,8 +298,11 @@ let string_of_type_extension te =
                            (List.map
                               (fun t -> "("^Odoc_print.string_of_type_expr t^")") l))
                       ^ " -> " ^ Odoc_print.string_of_type_expr r
-                  | T.Cstr_record _, _ ->
-                      assert false
+                  | T.Cstr_record l, None ->
+                      " of " ^  string_of_record l
+                  | T.Cstr_record l, Some r ->
+                      " : " ^ string_of_record l ^ " -> "
+                      ^ Odoc_print.string_of_type_expr r
                )
               ^(match x.M.xt_alias with
                     None -> ""
@@ -342,8 +345,11 @@ let string_of_exception e =
          (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))^
        " -> "^
        (Odoc_print.string_of_type_expr r)
-   | T.Cstr_record _, _ ->
-       assert false
+   | T.Cstr_record l, None ->
+       " of " ^  string_of_record l
+   | T.Cstr_record l, Some r ->
+       " : " ^ string_of_record l ^ " -> "
+       ^ Odoc_print.string_of_type_expr r
   )^
   (match e.M.ex_alias with
     None -> ""

diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml
index dd0264753629e8cf79c0c94c82eb2be54135edfe..dec7a1ec69b3374abd64ca464fad0f7409fb74c7 100644 (file)
--- a/ocamldoc/odoc_test.ml
+++ b/ocamldoc/odoc_test.ml
@@ -117,7 +117,7 @@ struct
     object
       inherit G.generator as base
 
-      method generate l =
+      method! generate l =
         base#generate l;
         g#generate l
     end

diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index eeaa2105d4e2f9a7f83eee928b5e41bcf1648fca..b52e03583ed470823914d6e4fedfd8e973c83648 100644 (file)
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -16,7 +16,6 @@
 (** Generation of Texinfo documentation. *)
 
 open Odoc_info
-open Parameter
 open Value
 open Type
 open Extension
@@ -273,7 +272,7 @@ class text =
 
     (** this method is not used here but is virtual
         in a class we will inherit later *)
-    method label ?(no_ : bool option) (_ : string) : string =
+    method label ?no_:(_ : bool option) (_ : string) : string =
       failwith "gni"
 
     (** Return the Texinfo code corresponding to the [text] parameter.*)
@@ -311,7 +310,7 @@ class text =
       | Odoc_info.Custom (s,t) -> self#texi_of_custom_text s t
       | Odoc_info.Target (target, code) -> self#texi_of_Target ~target ~code
 
-    method texi_of_custom_text s t = ""
+    method texi_of_custom_text _ _ = ""
 
     method texi_of_Target ~target ~code =
       if String.lowercase_ascii target = "texi" then code else ""
@@ -397,7 +396,7 @@ struct
     Texinfo documentation. *)
 class texi =
   object (self)
-    inherit text as to_texi
+    inherit text
     inherit Odoc_to_text.to_text as to_text
 
     (** {3 Small helper stuff.} *)
@@ -476,7 +475,7 @@ class texi =
                    Raw " " ; Raw s ] @ t @ [ Newline ])
            see_l)
 
-    method text_of_before l =
+    method! text_of_before l =
       List.flatten
       (List.map
         (fun x -> linebreak :: (to_text#text_of_before [x])) l)
@@ -886,7 +885,7 @@ class texi =
       self#texi_of_text t
 
     (** Return the Texinfo code for the given class element. *)
-    method texi_of_class_element class_name class_ele =
+    method texi_of_class_element _class_name class_ele =
       match class_ele with
       | Class_attribute att -> self#texi_of_attribute att
       | Class_method met -> self#texi_of_method met

diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly
index 5e0c7127408be0afca5a47fff108d03f9cba79f2..f71ab3777c13ceeb642438e5eda7bd6de2768c3a 100644 (file)
--- a/ocamldoc/odoc_text_parser.mly
+++ b/ocamldoc/odoc_text_parser.mly
@@ -16,8 +16,6 @@
 
 open Odoc_types
 
-let identchar =
-  "[A-Z a-z_\192-\214\216-\246\248-\255'0-9]"
 let blank = "[ \010\013\009\012]"
 
 let remove_beginning_blanks s =

diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml
index a602da6155c3dbc67f8375067084cb2a4848a729..fd65051009b93591694923c339920e4e3107ca6b 100644 (file)
--- a/ocamldoc/odoc_to_text.ml
+++ b/ocamldoc/odoc_to_text.ml
@@ -24,7 +24,6 @@ open Type
 open Value
 open Module
 open Class
-open Parameter
 
 (** A class used to get a [text] for info structures. *)
 class virtual info =
@@ -229,7 +228,8 @@ class virtual to_text =
 
     method normal_cstr_args ?par m_name = function
       | Cstr_tuple l -> self#normal_type_list ?par m_name " * " l
-      | Cstr_record _ -> "{...}" (* TODO *)
+      | Cstr_record r -> self#relative_idents m_name
+                            (Odoc_str.string_of_record r)
 
     (** Get a string for a list of class or class type type parameters
        where all idents are relative. *)
@@ -336,22 +336,20 @@ class virtual to_text =
       Format.fprintf Format.str_formatter "@[<hov 2>exception %s" s_name ;
       (match e.ex_args, e.ex_ret with
          Cstr_tuple [], None -> ()
-       | Cstr_tuple l, None ->
-           Format.fprintf Format.str_formatter " %s@ %s"
-             "of"
-             (self#normal_type_list ~par: false father " * " l)
        | Cstr_tuple [], Some r ->
            Format.fprintf Format.str_formatter " %s@ %s"
              ":"
              (self#normal_type father r)
-       | Cstr_tuple l, Some r ->
+       | args, None ->
+           Format.fprintf Format.str_formatter " %s@ %s"
+             "of"
+             (self#normal_cstr_args ~par:false father args)
+       | args, Some r ->
            Format.fprintf Format.str_formatter " %s@ %s@ %s@ %s"
              ":"
-             (self#normal_type_list ~par: false father " * " l)
+             (self#normal_cstr_args ~par:false father args)
              "->"
              (self#normal_type father r)
-       | Cstr_record _, _ ->
-           assert false
       );
       (match e.ex_alias with
          None -> ()
@@ -556,7 +554,7 @@ class virtual to_text =
           [Code ((if with_def_syntax then " : " else "")^
                  Odoc_messages.struct_end^" ")]
 
-      | Module_functor (p, k)  ->
+      | Module_functor (_, k)  ->
           (if with_def_syntax then [Code " : "] else []) @
           [Code "functor ... "] @
           [Code " -> "] @

diff --git a/otherlibs/Makefile b/otherlibs/Makefile
index 8846cd234a48ecb922976c885524dcee199a1b1f..4758bf599e5267dc06a1516acdac882921814483 100644 (file)
--- a/otherlibs/Makefile
+++ b/otherlibs/Makefile
@@ -13,13 +13,103 @@
 #*                                                                        *
 #**************************************************************************
 
-# Common Makefile for otherlibs on the Unix ports
+# Common Makefile for otherlibs
+
+ROOTDIR=../..
+include $(ROOTDIR)/config/Makefile
+CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
+CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
+
+ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+export OCAML_FLEXLINK:=
+else
+export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
+endif
 
 CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
 CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
         -I $(ROOTDIR)/stdlib
 CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
 
-include ../Makefile.shared
-# Note .. is the current directory (this makefile is included from
-# a subdirectory)
+# Compilation options
+CC=$(BYTECC)
+COMPFLAGS=-absname -w +a-4-9-41-42-44-45-48 -warn-error A -bin-annot -g \
+          -safe-string -strict-sequence -strict-formats $(EXTRACAMLFLAGS)
+ifeq "$(FLAMBDA)" "true"
+OPTCOMPFLAGS=-O3
+else
+OPTCOMPFLAGS=
+endif
+MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
+
+# Variables to be defined by individual libraries:
+#LIBNAME=
+#CLIBNAME=
+#CMIFILES=
+#CAMLOBJS=
+#COBJS=
+#EXTRACFLAGS=
+#EXTRACAMLFLAGS=
+#LINKOPTS=
+#LDOPTS=
+#HEADERS=
+
+CMIFILES ?= $(CAMLOBJS:.cmo=.cmi)
+CAMLOBJS_NAT ?= $(CAMLOBJS:.cmo=.cmx)
+CLIBNAME ?= $(LIBNAME)
+
+all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
+
+allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
+
+$(LIBNAME).cma: $(CAMLOBJS)
+       $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall \
+                $(CAMLOBJS) $(LINKOPTS)
+
+$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
+       $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall \
+                $(CAMLOBJS_NAT) $(LINKOPTS)
+
+$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A)
+       $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
+
+lib$(CLIBNAME).$(A): $(COBJS)
+       $(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS)
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
+
+install::
+       if test -f dll$(CLIBNAME)$(EXT_DLL); then \
+         cp dll$(CLIBNAME)$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/"; fi
+       cp lib$(CLIBNAME).$(A) "$(INSTALL_LIBDIR)/"
+       cd "$(INSTALL_LIBDIR)"; $(RANLIB) lib$(CLIBNAME).$(A)
+       cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) "$(INSTALL_LIBDIR)/"
+       if test -n "$(HEADERS)"; then \
+         cp $(HEADERS) "$(INSTALL_LIBDIR)/caml/"; fi
+
+installopt:
+       cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) "$(INSTALL_LIBDIR)/"
+       cd "$(INSTALL_LIBDIR)"; $(RANLIB) $(LIBNAME).a
+       if test -f $(LIBNAME).cmxs; then \
+         cp $(LIBNAME).cmxs "$(INSTALL_LIBDIR)/"; fi
+
+partialclean:
+       rm -f *.cm*
+
+clean:: partialclean
+       rm -f *.dll *.so *.a *.lib *.o *.obj
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(O)
+
+.mli.cmi:
+       $(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+       $(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+       $(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
+
+.c.$(O):
+       $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<

diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt
deleted file mode 100644 (file)
index e81590a..0000000
--- a/otherlibs/Makefile.nt
+++ /dev/null
@@ -1,27 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-# Common Makefile for otherlibs on the Win32/MinGW ports
-
-include ../Makefile
-
-ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
-export OCAML_FLEXLINK:=
-else
-export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
-endif
-
-# Note .. is the current directory (this makefile is included from
-# a subdirectory)

diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared
deleted file mode 100644 (file)
index 58e97c2..0000000
--- a/otherlibs/Makefile.shared
+++ /dev/null
@@ -1,104 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-# Common Makefile for otherlibs
-
-ROOTDIR=../..
-include $(ROOTDIR)/config/Makefile
-CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
-CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc
-
-# Compilation options
-CC=$(BYTECC)
-COMPFLAGS=-w +33..39+50 -warn-error A -bin-annot -g -safe-string \
-          $(EXTRACAMLFLAGS)
-ifeq "$(FLAMBDA)" "true"
-OPTCOMPFLAGS=-O3
-else
-OPTCOMPFLAGS=
-endif
-MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib
-
-# Variables to be defined by individual libraries:
-#LIBNAME=
-#CLIBNAME=
-#CMIFILES=
-#CAMLOBJS=
-#COBJS=
-#EXTRACFLAGS=
-#EXTRACAMLFLAGS=
-#LINKOPTS=
-#LDOPTS=
-#HEADERS=
-
-CMIFILES ?= $(CAMLOBJS:.cmo=.cmi)
-CAMLOBJS_NAT ?= $(CAMLOBJS:.cmo=.cmx)
-CLIBNAME ?= $(LIBNAME)
-
-all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
-
-allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
-
-$(LIBNAME).cma: $(CAMLOBJS)
-       $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall \
-                $(CAMLOBJS) $(LINKOPTS)
-
-$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
-       $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall \
-                $(CAMLOBJS_NAT) $(LINKOPTS)
-
-$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A)
-       $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
-
-lib$(CLIBNAME).$(A): $(COBJS)
-       $(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS)
-
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR)
-
-install::
-       if test -f dll$(CLIBNAME)$(EXT_DLL); then \
-         cp dll$(CLIBNAME)$(EXT_DLL) "$(INSTALL_STUBLIBDIR)/"; fi
-       cp lib$(CLIBNAME).$(A) "$(INSTALL_LIBDIR)/"
-       cd "$(INSTALL_LIBDIR)"; $(RANLIB) lib$(CLIBNAME).$(A)
-       cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) "$(INSTALL_LIBDIR)/"
-       if test -n "$(HEADERS)"; then \
-         cp $(HEADERS) "$(INSTALL_LIBDIR)/caml/"; fi
-
-installopt:
-       cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) "$(INSTALL_LIBDIR)/"
-       cd "$(INSTALL_LIBDIR)"; $(RANLIB) $(LIBNAME).a
-       if test -f $(LIBNAME).cmxs; then \
-         cp $(LIBNAME).cmxs "$(INSTALL_LIBDIR)/"; fi
-
-partialclean:
-       rm -f *.cm*
-
-clean:: partialclean
-       rm -f *.dll *.so *.a *.lib *.o *.obj
-
-.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(O)
-
-.mli.cmi:
-       $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmo:
-       $(CAMLC) -c $(COMPFLAGS) $<
-
-.ml.cmx:
-       $(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
-
-.c.$(O):
-       $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<

diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
index 2f419862fb77f79f0bbc9ce30ffb1c5d0703357e..5bf15bc9a275081133ac756c9d34995afc3d8b8e 100644 (file)
--- a/otherlibs/bigarray/.depend
+++ b/otherlibs/bigarray/.depend
@@ -20,6 +20,6 @@ mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/caml/config.h \
   ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \
   ../../byterun/caml/custom.h ../../byterun/caml/fail.h \
   ../../byterun/caml/sys.h ../unix/unixsupport.h
-bigarray.cmi :
 bigarray.cmo : bigarray.cmi
 bigarray.cmx : bigarray.cmi
+bigarray.cmi :

diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile
index 5bee2817a7df1d097ecf5733d00dc6cd9fc01433..7b95b51739d2bc9371877abe44ebc62bfa3a82f8 100644 (file)
--- a/otherlibs/bigarray/Makefile
+++ b/otherlibs/bigarray/Makefile
@@ -13,17 +13,10 @@
 #*                                                                        *
 #**************************************************************************
 
-LIBNAME=bigarray
-EXTRACFLAGS=-I../$(UNIXLIB) -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
-EXTRACAMLFLAGS=-I ../$(UNIXLIB)
-COBJS=bigarray_stubs.$(O) mmap_$(UNIX_OR_WIN32).$(O)
-CAMLOBJS=bigarray.cmo
-HEADERS=bigarray.h
-
-include ../Makefile
+include Makefile.shared
 
 depend:
        $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend

diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt
index 64f4a9673c61033b48583980c5ba3a84b62e6b15..2871177aec5c7fe4d920e15694ff5a4564b81f9b 100644 (file)
--- a/otherlibs/bigarray/Makefile.nt
+++ b/otherlibs/bigarray/Makefile.nt
@@ -13,17 +13,12 @@
 #*                                                                        *
 #**************************************************************************
 
-LIBNAME=bigarray
-EXTRACFLAGS=-I../win32unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
-EXTRACAMLFLAGS=-I ../win32unix
-COBJS=bigarray_stubs.$(O) mmap_win32.$(O)
-CAMLOBJS=bigarray.cmo
-HEADERS=bigarray.h
+# It would be better to move that to config/Makefile.*
+UNIX_OR_WIN32=win32
 
-include ../Makefile.nt
+include Makefile
 
-depend:
-       $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+.depend.nt: .depend
+       sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
 
-include .depend
+include .depend.nt

diff --git a/otherlibs/bigarray/Makefile.shared b/otherlibs/bigarray/Makefile.shared
new file mode 100644 (file)
index 0000000..0d515ed
--- /dev/null
+++ b/otherlibs/bigarray/Makefile.shared
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+LIBNAME=bigarray
+EXTRACFLAGS=-I../$(UNIXLIB) -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE
+EXTRACAMLFLAGS=-I ../$(UNIXLIB)
+COBJS=bigarray_stubs.$(O) mmap_$(UNIX_OR_WIN32).$(O)
+CAMLOBJS=bigarray.cmo
+HEADERS=bigarray.h
+
+include ../Makefile

diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml
index 77c200e2dbdd6d22bbf88f3e72ebd454373291ef..425dde11baef700875a9427203db634f3660665f 100644 (file)
--- a/otherlibs/bigarray/bigarray.ml
+++ b/otherlibs/bigarray/bigarray.ml
@@ -110,6 +110,8 @@ module Genarray = struct
 
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+     = "caml_ba_change_layout"
 
   let size_in_bytes arr =
     (kind_size_in_bytes (kind arr)) * (Array.fold_left ( * ) 1 (dims arr))
@@ -308,6 +310,7 @@ let _ =
   let _ = Array3.get in
   ()
 
+[@@@ocaml.warning "-32"]
 external get1: unit -> unit = "caml_ba_get_1"
 external get2: unit -> unit = "caml_ba_get_2"
 external get3: unit -> unit = "caml_ba_get_3"

diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli
index 6b9c6239931830dc284e21d2c9e2daa1ca8aa597..c805d5180dc2ee75665ec5795ccdd72b446daca9 100644 (file)
--- a/otherlibs/bigarray/bigarray.mli
+++ b/otherlibs/bigarray/bigarray.mli
@@ -172,7 +172,9 @@ val char : (char, int8_unsigned_elt) kind
 
 val kind_size_in_bytes : ('a, 'b) kind -> int
 (** [kind_size_in_bytes k] is the number of bytes used to store
-   an element of type [k]. *)
+   an element of type [k].
+
+   @since 4.03.0 *)
 
 (** {6 Array layouts} *)
 
@@ -286,9 +288,23 @@ module Genarray :
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   (** Return the layout of the given big array. *)
 
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+      = "caml_ba_change_layout"
+  (** [Genarray.change_layout a layout] returns a bigarray with the
+      specified [layout], sharing the data with [a] (and hence having
+      the same dimensions as [a]). No copying of elements is involved: the
+      new array and the original array share the same storage space.
+      The dimensions are reversed, such that [get v [| a; b |]] in
+      C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
+
+      @since 4.04.0
+  *)
+
   val size_in_bytes : ('a, 'b, 'c) t -> int
   (** [size_in_bytes a] is the number of elements in [a] multiplied
-    by [a]'s {!kind_size_in_bytes}.*)
+    by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
 
   external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic"
   (** Read an element of a generic big array.
@@ -502,7 +518,9 @@ module Array1 : sig
 
   val size_in_bytes : ('a, 'b, 'c) t -> int
   (** [size_in_bytes a] is the number of elements in [a]
-    multiplied by [a]'s {!kind_size_in_bytes}. *)
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
 
   external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1"
   (** [Array1.get a x], or alternatively [a.{x}],
@@ -588,7 +606,9 @@ module Array2 :
 
   val size_in_bytes : ('a, 'b, 'c) t -> int
   (** [size_in_bytes a] is the number of elements in [a]
-    multiplied by [a]'s {!kind_size_in_bytes}. *)
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
 
   external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2"
   (** [Array2.get a x y], also written [a.{x,y}],
@@ -698,7 +718,9 @@ module Array3 :
 
   val size_in_bytes : ('a, 'b, 'c) t -> int
   (** [size_in_bytes a] is the number of elements in [a]
-    multiplied by [a]'s {!kind_size_in_bytes}. *)
+    multiplied by [a]'s {!kind_size_in_bytes}.
+
+    @since 4.03.0 *)
 
   external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3"
   (** [Array3.get a x y z], also written [a.{x,y,z}],

diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c
index 6a885d081f776bfa20a0b30721f66e1d4f80438b..b0619cd721c496121c42598e03b040b9767fd154 100644 (file)
--- a/otherlibs/bigarray/bigarray_stubs.c
+++ b/otherlibs/bigarray/bigarray_stubs.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <stddef.h>
 #include <stdarg.h>
 #include <string.h>
@@ -1078,6 +1080,32 @@ CAMLprim value caml_ba_slice(value vb, value vind)
   #undef b
 }
 
+/* Changing the layout of an array (memory is shared) */
+
+CAMLprim value caml_ba_change_layout(value vb, value vlayout)
+{
+  CAMLparam2 (vb, vlayout);
+  CAMLlocal1 (res);
+  #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
+  /* if the layout is different, change the flags and reverse the dimensions */
+  if (Caml_ba_layout_val(vlayout) != (b->flags & CAML_BA_LAYOUT_MASK)) {
+    /* change the flags to reflect the new layout */
+    int flags = (b->flags & CAML_BA_KIND_MASK) | Caml_ba_layout_val(vlayout);
+    /* reverse the dimensions */
+    intnat new_dim[CAML_BA_MAX_NUM_DIMS];
+    unsigned int i;
+    for(i = 0; i < b->num_dims; i++) new_dim[i] = b->dim[b->num_dims - i - 1];
+    res = caml_ba_alloc(flags, b->num_dims, b->data, new_dim);
+    caml_ba_update_proxy(b, Caml_ba_array_val(res));
+    CAMLreturn(res);
+  } else {
+  /* otherwise, do nothing */
+  CAMLreturn(vb);
+  }
+  #undef b
+}
+
+
 /* Extracting a sub-array of same number of dimensions */
 
 CAMLprim value caml_ba_sub(value vb, value vofs, value vlen)

diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c
index 69a83361b2718ec5ae5940a20d2c08423e6f4481..f276514cef4a162e1b3a06332d67f0176b15ea77 100644 (file)
--- a/otherlibs/bigarray/mmap_unix.c
+++ b/otherlibs/bigarray/mmap_unix.c
@@ -13,9 +13,11 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* Needed (under Linux at least) to get pwrite's prototype in unistd.h.
    Must be defined before the first system .h is included. */
-#define _XOPEN_SOURCE 500
+#define _XOPEN_SOURCE 600
 
 #include <stddef.h>
 #include <string.h>

diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
index 8f57196c9870e0568665480873f83fcc7ca23665..35b40f6ec7751a185119bbacb1edec4f7f0e6d8f 100644 (file)
--- a/otherlibs/dynlink/Makefile
+++ b/otherlibs/dynlink/Makefile
@@ -26,8 +26,9 @@ OCAMLC    = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
 OCAMLOPT  = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib
 
 INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp
-COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string \
-          -I ../../stdlib $(INCLUDES)
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -bin-annot -g \
+   -I ../../stdlib -warn-error A \
+   -safe-string -strict-sequence -strict-formats
 ifeq "$(FLAMBDA)" "true"
 OPTCOMPFLAGS=-O3
 else

diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
index c9a0a3e13421435000d6d2c407fd23c3f22389c4..cbb1519478d1f23fcd5b34fc67391a40c0be88bd 100644 (file)
--- a/otherlibs/dynlink/dynlink.ml
+++ b/otherlibs/dynlink/dynlink.ml
@@ -1,3 +1,4 @@
+#2 "otherlibs/dynlink/dynlink.ml"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -92,7 +93,7 @@ let check_consistency file_name cu =
              else
                Consistbl.check_noadd !crc_interfaces name crc file_name)
       cu.cu_imports
-  with Consistbl.Inconsistency(name, user, auth) ->
+  with Consistbl.Inconsistency(name, _user, _auth) ->
          raise(Error(Inconsistent_import name))
      | Consistbl.Not_available(name) ->
          raise(Error(Unavailable_unit name))

diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml
index 5a70b1d377a209c91b38c5086a66086d05561f30..685b306b8f0913d69b71973f05a6939718abebd3 100644 (file)
--- a/otherlibs/dynlink/natdynlink.ml
+++ b/otherlibs/dynlink/natdynlink.ml
@@ -1,3 +1,4 @@
+#2 "otherlibs/dynlink/natdynlink.ml"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -120,16 +121,16 @@ let add_check_ifaces allow_ext filename ui ifaces =
            then StrMap.add name (crc,filename) ifaces
            else
              try
-               let (old_crc,old_src) = StrMap.find name ifaces in
+               let (old_crc, _old_src) = StrMap.find name ifaces in
                  if old_crc <> crc
-                 then raise(Error(Inconsistent_import(name)))
+                 then raise(Error(Inconsistent_import name))
                  else ifaces
              with Not_found ->
                if allow_ext then StrMap.add name (crc,filename) ifaces
                else raise (Error(Unavailable_unit name))
     ) ifaces ui.dynu_imports_cmi
 
-let check_implems filename ui implems =
+let check_implems ui implems =
   List.iter
     (fun (name, crco) ->
        match name with
@@ -147,10 +148,10 @@ let check_implems filename ui implems =
          |"Undefined_recursive_module" -> ()
          | _ ->
        try
-         let (old_crc,old_src,state) = StrMap.find name implems in
+         let (old_crc, _old_src, state) = StrMap.find name implems in
            match crco with
              Some crc when old_crc <> crc ->
-               raise(Error(Inconsistent_implementation(name)))
+               raise(Error(Inconsistent_implementation name))
            | _ ->
                match state with
                | Check_inited i ->
@@ -169,7 +170,7 @@ let loadunits filename handle units state =
   let new_implems =
     List.fold_left
       (fun accu ui ->
-         check_implems filename ui accu;
+         check_implems ui accu;
          StrMap.add ui.dynu_name (ui.dynu_crc,filename,Loaded) accu)
       state.implems units in
 

diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
index 06ba20b855b6b7dd7983ec30fd46a08963ed27e7..ada82fd646bcd767edbf2627232ee1862f3b56b8 100644 (file)
--- a/otherlibs/graph/.depend
+++ b/otherlibs/graph/.depend
@@ -21,10 +21,7 @@ dump_img.o: dump_img.c libgraph.h \
   ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h image.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h
 events.o: events.c libgraph.h \
   \
   \
@@ -40,9 +37,7 @@ fill.o: fill.c libgraph.h \
   ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h
+  ../../byterun/caml/memory.h
 image.o: image.c libgraph.h \
   \
   \
@@ -58,9 +53,7 @@ make_img.o: make_img.c libgraph.h \
   ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h image.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h
+  ../../byterun/caml/memory.h
 open.o: open.c libgraph.h \
   \
   \
@@ -69,10 +62,7 @@ open.o: open.c libgraph.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/callback.h \
-  ../../byterun/caml/fail.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h
+  ../../byterun/caml/fail.h ../../byterun/caml/memory.h
 point_col.o: point_col.c libgraph.h \
   \
   \
@@ -102,9 +92,9 @@ text.o: text.c libgraph.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h
-graphics.cmi :
-graphicsX11.cmi :
 graphics.cmo : graphics.cmi
 graphics.cmx : graphics.cmi
+graphics.cmi :
 graphicsX11.cmo : graphics.cmi graphicsX11.cmi
 graphicsX11.cmx : graphics.cmx graphicsX11.cmi
+graphicsX11.cmi :

diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
index 4e844d749f93599e348909a33dea53608e5e1161..6887554320fec78d698298a33e18976c67619803 100644 (file)
--- a/otherlibs/graph/Makefile
+++ b/otherlibs/graph/Makefile
@@ -29,6 +29,6 @@ include ../Makefile
 
 depend:
        $(CC) -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend
-       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend

diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c
index 4a685f048b3b0d9d2f0baf0559cb6baeeabc0cda..164c3601590e62d2e4fd9535e0991c9cb66e8d3b 100644 (file)
--- a/otherlibs/graph/events.c
+++ b/otherlibs/graph/events.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <signal.h>
 #include "libgraph.h"
 #include <caml/alloc.h>

diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml
index 84cea7d5856a14ea0542b68b8ddc941c702846e7..3632898699635748d092d4ffb7010918f57f7cde 100644 (file)
--- a/otherlibs/graph/graphics.ml
+++ b/otherlibs/graph/graphics.ml
@@ -231,8 +231,7 @@ let loop_at_exit events handler =
 external sound : int -> int -> unit = "caml_gr_sound"
 
 (* Splines *)
-let add (x1, y1) (x2, y2) = (x1 +. x2, y1 +. y2)
-and sub (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2)
+let sub (x1, y1) (x2, y2) = (x1 -. x2, y1 -. y2)
 and middle (x1, y1) (x2, y2) = ((x1 +. x2) /. 2.0,  (y1 +. y2) /. 2.0)
 and area (x1, y1) (x2, y2) = abs_float (x1 *. y2 -. x2 *. y1)
 and norm (x1, y1) = sqrt (x1 *. x1 +. y1 *. y1);;

diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend
index 7e8a39991012b415761a2346625abd1f1d916c7d..906bca5e3466a63c15a73d05c49a1a70ea842c52 100644 (file)
--- a/otherlibs/num/.depend
+++ b/otherlibs/num/.depend
@@ -18,24 +18,24 @@ nat_stubs.o: nat_stubs.c ../../byterun/caml/alloc.h \
   ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
   ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
   ../../byterun/caml/address_class.h bng.h nat.h
-arith_flags.cmi :
-arith_status.cmi :
-big_int.cmi : nat.cmi
-int_misc.cmi :
-nat.cmi :
-num.cmi : ratio.cmi nat.cmi big_int.cmi
-ratio.cmi : nat.cmi big_int.cmi
 arith_flags.cmo : arith_flags.cmi
 arith_flags.cmx : arith_flags.cmi
+arith_flags.cmi :
 arith_status.cmo : arith_flags.cmi arith_status.cmi
 arith_status.cmx : arith_flags.cmx arith_status.cmi
+arith_status.cmi :
 big_int.cmo : nat.cmi int_misc.cmi big_int.cmi
 big_int.cmx : nat.cmx int_misc.cmx big_int.cmi
+big_int.cmi : nat.cmi
 int_misc.cmo : int_misc.cmi
 int_misc.cmx : int_misc.cmi
+int_misc.cmi :
 nat.cmo : int_misc.cmi nat.cmi
 nat.cmx : int_misc.cmx nat.cmi
+nat.cmi :
 num.cmo : ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
 num.cmx : ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+num.cmi : ratio.cmi nat.cmi big_int.cmi
 ratio.cmo : nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
 ratio.cmx : nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
+ratio.cmi : nat.cmi big_int.cmi

diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
index 344789b17c09d59fd55022ec1498960fa9f515f3..7b95b51739d2bc9371877abe44ebc62bfa3a82f8 100644 (file)
--- a/otherlibs/num/Makefile
+++ b/otherlibs/num/Makefile
@@ -13,25 +13,10 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the "num" (exact rational arithmetic) library
-
-LIBNAME=nums
-EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
-CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
-  ratio.cmo num.cmo arith_status.cmo
-CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
-COBJS=bng.$(O) nat_stubs.$(O)
-
-include ../Makefile
-
-clean::
-       rm -f *~
-
-bng.$(O): bng.h bng_digit.c \
-       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
+include Makefile.shared
 
 depend:
        $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend

diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
index 2b0fab0a846abc13292ed6e4c20d40168de9331f..1c47f07be9f7e7d19f59457bd6c51824f5d0999b 100644 (file)
--- a/otherlibs/num/Makefile.nt
+++ b/otherlibs/num/Makefile.nt
@@ -13,22 +13,7 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the "num" (exact rational arithmetic) library
-
-LIBNAME=nums
-EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
-CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
-  ratio.cmo num.cmo arith_status.cmo
-CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
-COBJS=bng.$(O) nat_stubs.$(O)
-
-include ../Makefile.nt
-
-clean::
-       rm -f *~
-
-bng.$(O): bng.h bng_digit.c \
-       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
+include Makefile.shared
 
 depend:
        sed -e 's/\.o/.$(O)/g' .depend > .depend.nt

diff --git a/otherlibs/num/Makefile.shared b/otherlibs/num/Makefile.shared
new file mode 100644 (file)
index 0000000..1487786
--- /dev/null
+++ b/otherlibs/num/Makefile.shared
@@ -0,0 +1,37 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the "num" (exact rational arithmetic) library
+
+LIBNAME=nums
+EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
+CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
+  ratio.cmo num.cmo arith_status.cmo
+CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
+COBJS=bng.$(O) nat_stubs.$(O)
+
+include ../Makefile
+
+clean::
+       rm -f *~
+
+bng.$(O): bng.h bng_digit.c \
+       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
+
+depend:
+       $(CC) -MM $(CFLAGS) *.c > .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+
+include .depend

diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli
index 9bbc7828c7ab3fb0296afb37600b11fecc9d1c35..ba604347fb1cc7b9b24aa7efdbd005192502823d 100644 (file)
--- a/otherlibs/num/arith_status.mli
+++ b/otherlibs/num/arith_status.mli
@@ -19,7 +19,7 @@ val arith_status: unit -> unit
         (** Print the current status of the arithmetic flags. *)
 
 val get_error_when_null_denominator : unit -> bool
-        (** See {!Arith_status.set_error_when_null_denominator}.*)
+(** See {!Arith_status.set_error_when_null_denominator}.*)
 
 val set_error_when_null_denominator : bool -> unit
         (** Get or set the flag [null_denominator]. When on, attempting to
@@ -28,7 +28,7 @@ val set_error_when_null_denominator : bool -> unit
            Initially: on. *)
 
 val get_normalize_ratio : unit -> bool
-        (** See {!Arith_status.set_normalize_ratio}.*)
+(** See {!Arith_status.set_normalize_ratio}.*)
 
 val set_normalize_ratio : bool -> unit
         (** Get or set the flag [normalize_ratio]. When on, rational
@@ -37,7 +37,7 @@ val set_normalize_ratio : bool -> unit
            Initially: off. *)
 
 val get_normalize_ratio_when_printing : unit -> bool
-        (** See {!Arith_status.set_normalize_ratio_when_printing}.*)
+(** See {!Arith_status.set_normalize_ratio_when_printing}.*)
 
 val set_normalize_ratio_when_printing : bool -> unit
         (** Get or set the flag [normalize_ratio_when_printing].
@@ -46,7 +46,7 @@ val set_normalize_ratio_when_printing : bool -> unit
            Initially: on. *)
 
 val get_approx_printing : unit -> bool
-        (** See {!Arith_status.set_approx_printing}.*)
+(** See {!Arith_status.set_approx_printing}.*)
 
 val set_approx_printing : bool -> unit
         (** Get or set the flag [approx_printing].
@@ -55,7 +55,7 @@ val set_approx_printing : bool -> unit
            Initially: off. *)
 
 val get_floating_precision : unit -> int
-        (** See {!Arith_status.set_floating_precision}.*)
+(** See {!Arith_status.set_floating_precision}.*)
 
 val set_floating_precision : int -> unit
         (** Get or set the parameter [floating_precision].

diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml
index 6fb030d5a4ecceff6c32d83dff8849d49916781a..efe376cad86f3ae0cf601df53e1d580be4ef9f02 100644 (file)
--- a/otherlibs/num/big_int.ml
+++ b/otherlibs/num/big_int.ml
@@ -464,7 +464,7 @@ let power_base_nat base nat off len =
   if base = 0 then nat_of_int 0 else
   if is_zero_nat nat off len || base = 1 then nat_of_int 1 else
   let power_base = make_nat (succ length_of_digit) in
-  let (pmax, pint) = make_power_base base power_base in
+  let (pmax, _pint) = make_power_base base power_base in
   let (n, rem) =
       let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len)
                                   (big_int_of_int (succ pmax)) in
@@ -662,10 +662,10 @@ let approx_big_int prec bi =
     Bytes.unsafe_of_string
       (string_of_big_int (div_big_int bi (power_int_positive_int 10 n)))
   in
-  let (sign, off, len) =
+  let (sign, off) =
     if Bytes.get s 0 = '-'
-       then ("-", 1, succ prec)
-       else ("", 0, prec) in
+       then ("-", 1)
+       else ("", 0) in
   if (round_futur_last_digit s off (succ prec))
        then (sign^"1."^(String.make prec '0')^"e"^
              (string_of_int (n + 1 - off + Bytes.length s)))

diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
index 011b83c33fb240d3a293efd31181093e2728e674..f5b2800fa016eccbb0781d0a2de21b006af6a0f8 100644 (file)
--- a/otherlibs/num/big_int.mli
+++ b/otherlibs/num/big_int.mli
@@ -24,7 +24,7 @@ type big_int
         (** The type of big integers. *)
 
 val zero_big_int : big_int
-        (** The big integer [0]. *)
+(** The big integer [0]. *)
 
 val unit_big_int : big_int
         (** The big integer [1]. *)
@@ -32,39 +32,39 @@ val unit_big_int : big_int
 (** {6 Arithmetic operations} *)
 
 val minus_big_int : big_int -> big_int
-        (** Unary negation. *)
+(** Unary negation. *)
 
 val abs_big_int : big_int -> big_int
-        (** Absolute value. *)
+(** Absolute value. *)
 
 val add_big_int : big_int -> big_int -> big_int
-        (** Addition. *)
+(** Addition. *)
 
 val succ_big_int : big_int -> big_int
-        (** Successor (add 1). *)
+(** Successor (add 1). *)
 
 val add_int_big_int : int -> big_int -> big_int
-        (** Addition of a small integer to a big integer. *)
+(** Addition of a small integer to a big integer. *)
 
 val sub_big_int : big_int -> big_int -> big_int
-        (** Subtraction. *)
+(** Subtraction. *)
 
 val pred_big_int : big_int -> big_int
-        (** Predecessor (subtract 1). *)
+(** Predecessor (subtract 1). *)
 
 val mult_big_int : big_int -> big_int -> big_int
-        (** Multiplication of two big integers. *)
+(** Multiplication of two big integers. *)
 
 val mult_int_big_int : int -> big_int -> big_int
-        (** Multiplication of a big integer by a small integer *)
+(** Multiplication of a big integer by a small integer *)
 
 val square_big_int: big_int -> big_int
-        (** Return the square of the given big integer *)
+(** Return the square of the given big integer *)
 
 val sqrt_big_int: big_int -> big_int
         (** [sqrt_big_int a] returns the integer square root of [a],
            that is, the largest big integer [r] such that [r * r <= a].
-           Raise [Invalid_argument] if [a] is negative. *)
+            Raise [Invalid_argument] if [a] is negative. *)
 
 val quomod_big_int : big_int -> big_int -> big_int * big_int
         (** Euclidean division of two big integers.
@@ -72,18 +72,18 @@ val quomod_big_int : big_int -> big_int -> big_int * big_int
            the second part is the remainder.
            Writing [(q,r) = quomod_big_int a b], we have
            [a = q * b + r] and [0 <= r < |b|].
-           Raise [Division_by_zero] if the divisor is zero. *)
+            Raise [Division_by_zero] if the divisor is zero. *)
 
 val div_big_int : big_int -> big_int -> big_int
         (** Euclidean quotient of two big integers.
-           This is the first result [q] of [quomod_big_int] (see above). *)
+            This is the first result [q] of [quomod_big_int] (see above). *)
 
 val mod_big_int : big_int -> big_int -> big_int
         (** Euclidean modulus of two big integers.
-           This is the second result [r] of [quomod_big_int] (see above). *)
+            This is the second result [r] of [quomod_big_int] (see above). *)
 
 val gcd_big_int : big_int -> big_int -> big_int
-        (** Greatest common divisor of two big integers. *)
+(** Greatest common divisor of two big integers. *)
 
 val power_int_positive_int: int -> int -> big_int
 val power_big_int_positive_int: big_int -> int -> big_int
@@ -99,41 +99,43 @@ val power_big_int_positive_big_int: big_int -> big_int -> big_int
 
 val sign_big_int : big_int -> int
         (** Return [0] if the given big integer is zero,
-           [1] if it is positive, and [-1] if it is negative. *)
+            [1] if it is positive, and [-1] if it is negative. *)
 
 val compare_big_int : big_int -> big_int -> int
         (** [compare_big_int a b] returns [0] if [a] and [b] are equal,
            [1] if [a] is greater than [b], and [-1] if [a] is smaller
-           than [b]. *)
+            than [b]. *)
 
 val eq_big_int : big_int -> big_int -> bool
 val le_big_int : big_int -> big_int -> bool
 val ge_big_int : big_int -> big_int -> bool
 val lt_big_int : big_int -> big_int -> bool
 val gt_big_int : big_int -> big_int -> bool
-        (** Usual boolean comparisons between two big integers. *)
+(** Usual boolean comparisons between two big integers. *)
 
 val max_big_int : big_int -> big_int -> big_int
-        (** Return the greater of its two arguments. *)
+(** Return the greater of its two arguments. *)
 
 val min_big_int : big_int -> big_int -> big_int
-        (** Return the smaller of its two arguments. *)
+(** Return the smaller of its two arguments. *)
 
 val num_digits_big_int : big_int -> int
         (** Return the number of machine words used to store the
-           given big integer.  *)
+            given big integer.  *)
 
 val num_bits_big_int : big_int -> int
         (** Return the number of significant bits in the absolute
             value of the given big integer.  [num_bits_big_int a]
             returns 0 if [a] is 0; otherwise it returns a positive
-            integer [n] such that [2^(n-1) <= |a| < 2^n]. *)
+            integer [n] such that [2^(n-1) <= |a| < 2^n].
+
+            @since 4.03.0 *)
 
 (** {6 Conversions to and from strings} *)
 
 val string_of_big_int : big_int -> string
         (** Return the string representation of the given big integer,
-           in decimal (base 10). *)
+            in decimal (base 10). *)
 
 val big_int_of_string : string -> big_int
         (** Convert a string to a big integer, in decimal.
@@ -143,7 +145,7 @@ val big_int_of_string : string -> big_int
 (** {6 Conversions to and from other numerical types} *)
 
 val big_int_of_int : int -> big_int
-        (** Convert a small integer to a big integer. *)
+(** Convert a small integer to a big integer. *)
 
 val is_int_big_int : big_int -> bool
         (** Test whether the given big integer is small enough to
@@ -152,7 +154,7 @@ val is_int_big_int : big_int -> bool
            [is_int_big_int a] returns [true] if and only if
            [a] is between 2{^30} and 2{^30}-1.  On a 64-bit platform,
            [is_int_big_int a] returns [true] if and only if
-           [a] is between -2{^62} and 2{^62}-1. *)
+            [a] is between -2{^62} and 2{^62}-1. *)
 
 val int_of_big_int : big_int -> int
         (** Convert a big integer to a small integer (type [int]).
@@ -160,13 +162,13 @@ val int_of_big_int : big_int -> int
            is not representable as a small integer. *)
 
 val big_int_of_int32 : int32 -> big_int
-        (** Convert a 32-bit integer to a big integer. *)
+(** Convert a 32-bit integer to a big integer. *)
 
 val big_int_of_nativeint : nativeint -> big_int
-        (** Convert a native integer to a big integer. *)
+(** Convert a native integer to a big integer. *)
 
 val big_int_of_int64 : int64 -> big_int
-        (** Convert a 64-bit integer to a big integer. *)
+(** Convert a 64-bit integer to a big integer. *)
 
 val int32_of_big_int : big_int -> int32
         (** Convert a big integer to a 32-bit integer.
@@ -226,10 +228,13 @@ val extract_big_int : big_int -> int -> int -> big_int
 (**/**)
 
 (** {6 For internal use} *)
+
 val nat_of_big_int : big_int -> nat
 val big_int_of_nat : nat -> big_int
 val base_power_big_int: int -> int -> big_int -> big_int
 val sys_big_int_of_string: string -> int -> int -> big_int
 val round_futur_last_digit : bytes -> int -> int -> bool
 val approx_big_int: int -> big_int -> string
+
 val round_big_int_to_float: big_int -> bool -> float
+(* @since 4.03.0 *)

diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml
index c0edabd9749becfc344045c5de85e6ab55bcd15b..c7a2669840c366f97c8e1ba3e3098ccd66f90b97 100644 (file)
--- a/otherlibs/num/nat.ml
+++ b/otherlibs/num/nat.ml
@@ -155,6 +155,7 @@ let square_nat nat1 off1 len1 nat2 off2 len2 =
   !c
 ***)
 
+(*
 let gcd_int_nat i nat off len =
   if i = 0 then 1 else
   if is_nat_int nat off len then begin
@@ -170,6 +171,7 @@ let gcd_int_nat i nat off len =
     set_digit_nat nat off (gcd_int (nth_digit_nat remainder 0) i);
     0
   end
+*)
 
 let exchange r1 r2 =
   let old1 = !r1 in r1 := !r2; r2 := old1
@@ -335,8 +337,6 @@ let string_of_digit nat =
 
 *******)
 
-let digits = "0123456789ABCDEF"
-
 (*
    make_power_base affecte power_base des puissances successives de base a
    partir de la puissance 1-ieme.
@@ -363,11 +363,14 @@ let make_power_base base power_base =
    while !j < !i - 1 && is_digit_int power_base !j do incr j done;
   (!i - 2, !j)
 
+(*
 (*
    int_to_string places the representation of the integer int in base 'base'
    in the string s by starting from the end position pos and going towards
    the start, for 'times' places and updates the value of pos.
 *)
+let digits = "0123456789ABCDEF"
+
 let int_to_string int s pos_ref base times =
   let i = ref int
   and j = ref times in
@@ -377,6 +380,7 @@ let int_to_string int s pos_ref base times =
         decr j;
         i := !i / base
      done
+*)
 
 let power_base_int base i =
   if i = 0 || base = 1 then
@@ -387,7 +391,7 @@ let power_base_int base i =
     invalid_arg "power_base_int"
   else begin
          let power_base = make_nat (succ length_of_digit) in
-         let (pmax, pint) = make_power_base base power_base in
+         let (pmax, _pint) = make_power_base base power_base in
          let n = i / (succ pmax)
          and rem = i mod (succ pmax) in
            if n > 0 then begin

diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
index 005aaffe874c2f940b9ff94d82661c170e8ce41b..f85d7c13022d7bf96a167c56100d6db6b9259511 100644 (file)
--- a/otherlibs/num/nat_stubs.c
+++ b/otherlibs/num/nat_stubs.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include "caml/alloc.h"
 #include "caml/config.h"
 #include "caml/custom.h"

diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
index 0a85951c87bf2bc7924f48fede2868419ad2d1bd..d3d76eac3a88bc9bdb643659bbb81d4d1a995077 100644 (file)
--- a/otherlibs/num/num.ml
+++ b/otherlibs/num/num.ml
@@ -31,14 +31,6 @@ let num_of_big_int bi =
  then Int (int_of_big_int bi)
  else Big_int bi
 
-let numerator_num = function
-  Ratio r -> ignore (normalize_ratio r); num_of_big_int (numerator_ratio r)
-| n -> n
-
-let denominator_num = function
-  Ratio r -> ignore (normalize_ratio r); num_of_big_int (denominator_ratio r)
-| n -> Int 1
-
 let normalize_num = function
   Int i -> Int i
 | Big_int bi -> num_of_big_int bi
@@ -158,8 +150,8 @@ let div_num n1 n2 =
 let ( // ) = div_num
 
 let floor_num = function
-  Int i as n -> n
-| Big_int bi as n -> n
+  Int _ as n -> n
+| Big_int _ as n -> n
 | Ratio r -> num_of_big_int (floor_ratio r)
 
 (* Coercion with ratio type *)
@@ -284,18 +276,18 @@ let is_integer_num = function
 
 (* integer_num, floor_num, round_num, ceiling_num rendent des nums *)
 let integer_num = function
-  Int i as n -> n
-| Big_int bi as n -> n
+  Int _ as n -> n
+| Big_int _ as n -> n
 | Ratio r -> num_of_big_int (integer_ratio r)
 
 and round_num = function
-  Int i as n -> n
-| Big_int bi as n -> n
+  Int _ as n -> n
+| Big_int _ as n -> n
 | Ratio r -> num_of_big_int (round_ratio r)
 
 and ceiling_num = function
-  Int i as n -> n
-| Big_int bi as n -> n
+  Int _ as n -> n
+| Big_int _ as n -> n
 | Ratio r -> num_of_big_int (ceiling_ratio r)
 
 (* Comparisons on nums *)

diff --git a/otherlibs/raw_spacetime_lib/.depend b/otherlibs/raw_spacetime_lib/.depend
new file mode 100644 (file)
index 0000000..ddc792f
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/.depend
@@ -0,0 +1,42 @@
+aProf.cmi :
+camlinternalAProf.cmi :
+aProf.cmo : aProf.cmi
+aProf.cmx : aProf.cmi
+camlinternalAProf.cmo : camlinternalAProf.cmi
+camlinternalAProf.cmx : camlinternalAProf.cmi
+aProf.cmi :
+camlinternalAProf.cmi :
+aProf.cmo : camlinternalAProf.cmi aProf.cmi
+aProf.cmx : camlinternalAProf.cmx aProf.cmi
+camlinternalAProf.cmo : camlinternalAProf.cmi
+camlinternalAProf.cmx : camlinternalAProf.cmi
+aProf.cmi :
+rawAProf.cmi :
+aProf.cmo : aProf.cmi
+aProf.cmx : aProf.cmi
+rawAProf.cmo : rawAProf.cmi
+rawAProf.cmx : rawAProf.cmi
+aProf.cmo : rawAProf.cmi aProf.cmi
+aProf.cmx : rawAProf.cmx aProf.cmi
+aProf.cmi :
+rawAProf.cmo : rawAProf.cmi
+rawAProf.cmx : rawAProf.cmi
+rawAProf.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+spacetime_lib.cmo : raw_spacetime_lib.cmi spacetime_lib.cmi
+spacetime_lib.cmx : raw_spacetime_lib.cmx spacetime_lib.cmi
+spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :
+raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
+raw_spacetime_lib.cmi :

diff --git a/otherlibs/raw_spacetime_lib/Makefile b/otherlibs/raw_spacetime_lib/Makefile
new file mode 100644 (file)
index 0000000..3dd7a32
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/Makefile
@@ -0,0 +1,25 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           Xavier Leroy, projet Cristal, INRIA Rocquencourt             *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Common Makefile for otherlibs on the Unix ports
+
+CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
+CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
+        -I $(ROOTDIR)/stdlib
+CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
+
+include Makefile.shared
+# Note .. is the current directory (this makefile is included from
+# a subdirectory)

diff --git a/otherlibs/raw_spacetime_lib/Makefile.nt b/otherlibs/raw_spacetime_lib/Makefile.nt
new file mode 100644 (file)
index 0000000..f8fdacc
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/Makefile.nt
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           Xavier Leroy, projet Cristal, INRIA Rocquencourt             *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Common Makefile for otherlibs on the Win32/MinGW ports
+
+include Makefile
+
+# The Unix version now works fine under Windows
+
+# Note .. is the current directory (this makefile is included from
+# a subdirectory)

diff --git a/otherlibs/raw_spacetime_lib/Makefile.shared b/otherlibs/raw_spacetime_lib/Makefile.shared
new file mode 100644 (file)
index 0000000..a43fe4d
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/Makefile.shared
@@ -0,0 +1,74 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*           Mark Shinwell and Leo White, Jane Street Europe              *
+#*                                                                        *
+#*   Copyright 2015--2016 Jane Street Group LLC                           *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for Raw_spacetime_lib
+
+ROOTDIR=../..
+include $(ROOTDIR)/config/Makefile
+CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
+
+LIBNAME=raw_spacetime_lib
+CAMLOBJS=raw_spacetime_lib.cmo
+
+CC=$(BYTECC)
+COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string $(EXTRACAMLFLAGS)
+
+CMIFILES=$(CAMLOBJS:.cmo=.cmi)
+CAMLOBJS_NAT=$(CAMLOBJS:.cmo=.cmx)
+
+all: $(LIBNAME).cma $(CMIFILES)
+
+allopt: $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES)
+
+$(LIBNAME).cma: $(CAMLOBJS)
+       $(CAMLC) -a -o $(LIBNAME).cma -linkall $(CAMLOBJS)
+
+$(LIBNAME).cmxa: $(CAMLOBJS_NAT)
+       $(CAMLOPT) -a -o $(LIBNAME).cmxa -linkall $(CAMLOBJS_NAT)
+
+$(LIBNAME).cmxs: $(LIBNAME).cmxa
+       $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa
+
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+
+install::
+       cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(INSTALL_LIBDIR)
+
+installopt:
+       cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALL_LIBDIR)/
+       if test -f $(LIBNAME).cmxs; then \
+         cp $(LIBNAME).cmxs $(INSTALL_LIBDIR)/; \
+       fi
+
+partialclean:
+       rm -f *.cm*
+
+clean:: partialclean
+       rm -f *.a *.o
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx
+
+.mli.cmi:
+       $(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+       $(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+       $(CAMLOPT) -c $(COMPFLAGS) $<
+
+depend:
+       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+
+include .depend

diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
new file mode 100644 (file)
index 0000000..e1010a9
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
@@ -0,0 +1,644 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Gc_stats : sig
+  type t
+
+  val minor_words : t -> int
+  val promoted_words : t -> int
+  val major_words : t -> int
+  val minor_collections : t -> int
+  val major_collections : t -> int
+  val heap_words : t -> int
+  val heap_chunks : t -> int
+  val compactions : t -> int
+  val top_heap_words : t -> int
+end = struct
+  type t = {
+    minor_words : int;
+    promoted_words : int;
+    major_words : int;
+    minor_collections : int;
+    major_collections : int;
+    heap_words : int;
+    heap_chunks : int;
+    compactions : int;
+    top_heap_words : int;
+  }
+
+  let minor_words t = t.minor_words
+  let promoted_words t = t.promoted_words
+  let major_words t = t.major_words
+  let minor_collections t = t.minor_collections
+  let major_collections t = t.major_collections
+  let heap_words t = t.heap_words
+  let heap_chunks t = t.heap_chunks
+  let compactions t = t.compactions
+  let top_heap_words t = t.top_heap_words
+end
+
+module Program_counter = struct
+  module OCaml = struct
+    type t = Int64.t
+
+    let to_int64 t = t
+  end
+
+  module Foreign = struct
+    type t = Int64.t
+
+    let to_int64 t = t
+  end
+end
+
+module Function_identifier = struct
+  type t = Int64.t
+
+  let to_int64 t = t
+end
+
+module Function_entry_point = struct
+  type t = Int64.t
+
+  let to_int64 t = t
+end
+
+module Int64_map = Map.Make (Int64)
+
+module Frame_table = struct
+  type raw = (Int64.t * (Printexc.Slot.t list)) list
+
+  type t = Printexc.Slot.t list Int64_map.t
+
+  let demarshal chn : t =
+    let raw : raw = Marshal.from_channel chn in
+    List.fold_left (fun map (pc, rev_location_list) ->
+        Int64_map.add pc (List.rev rev_location_list) map)
+      Int64_map.empty
+      raw
+
+  let find_exn = Int64_map.find
+end
+
+module Shape_table = struct
+  type part_of_shape =
+    | Direct_call of { call_site : Int64.t; callee : Int64.t; }
+    | Indirect_call of Int64.t
+    | Allocation_point of Int64.t
+
+  let _ = Direct_call { call_site = 0L; callee = 0L; }
+  let _ = Indirect_call 0L
+  let _ = Allocation_point 0L
+
+  let part_of_shape_size = function
+    | Direct_call _
+    | Indirect_call _ -> 1
+    | Allocation_point _ -> 3
+
+  type raw = (Int64.t * (part_of_shape list)) list
+
+  type t = part_of_shape list Int64_map.t
+
+  let demarshal chn : t =
+    let raw : raw = Marshal.from_channel chn in
+    List.fold_left (fun map (key, data) -> Int64_map.add key data map)
+      Int64_map.empty
+      raw
+
+  let find_exn = Int64_map.find
+end
+
+module Annotation = struct
+  type t = int
+
+  let to_int t = t
+end
+
+module Trace = struct
+  type node
+  type ocaml_node
+  type foreign_node
+  type uninstrumented_node
+
+  type t = node option
+
+  (* This function unmarshals into malloc blocks, which mean that we
+     obtain a straightforward means of writing [compare] on [node]s. *)
+  external unmarshal : in_channel -> 'a
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_unmarshal_trie"
+
+  let unmarshal in_channel =
+    let trace = unmarshal in_channel in
+    if trace = () then
+      None
+    else
+      Some ((Obj.magic trace) : node)
+
+  let node_is_null (node : node) =
+    ((Obj.magic node) : unit) == ()
+
+  let foreign_node_is_null (node : foreign_node) =
+    ((Obj.magic node) : unit) == ()
+
+  external node_num_header_words : unit -> int
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_node_num_header_words" "noalloc"
+
+  let num_header_words = lazy (node_num_header_words ())
+
+  module OCaml = struct
+    type field_iterator = {
+      node : ocaml_node;
+      offset : int;
+      part_of_shape : Shape_table.part_of_shape;
+      remaining_layout : Shape_table.part_of_shape list;
+      shape_table : Shape_table.t;
+    }
+
+    module Allocation_point = struct
+      type t = field_iterator
+
+      let program_counter t =
+        match t.part_of_shape with
+        | Shape_table.Allocation_point call_site -> call_site
+        | _ -> assert false
+
+      external annotation : ocaml_node -> int -> Annotation.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_allocation_point_annotation"
+          "noalloc"
+
+      let annotation t = annotation t.node t.offset
+
+      external count : ocaml_node -> int -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_allocation_point_count"
+          "noalloc"
+
+      let num_words_including_headers t = count t.node t.offset
+    end
+
+    module Direct_call_point = struct
+      type _ t = field_iterator
+
+      let call_site t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call { call_site; _ } -> call_site
+        | _ -> assert false
+
+      let callee t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call { callee; _ } -> callee
+        | _ -> assert false
+
+      external callee_node : ocaml_node -> int -> 'target
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_direct_call_point_callee_node"
+
+      let callee_node (type target) (t : target t) : target =
+        callee_node t.node t.offset
+    end
+
+    module Indirect_call_point = struct
+      type t = field_iterator
+
+      let call_site t =
+        match t.part_of_shape with
+        | Shape_table.Indirect_call call_site -> call_site
+        | _ -> assert false
+
+      module Callee = struct
+        (* CR-soon mshinwell: we should think about the names again.  This is
+           a "c_node" but it isn't foreign. *)
+        type t = foreign_node
+
+        let is_null = foreign_node_is_null
+
+        (* CR-soon mshinwell: maybe rename ...c_node_call_site -> c_node_pc,
+           since it isn't a call site in this case. *)
+        external callee : t -> Function_entry_point.t
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_call_site"
+
+        (* This can return a node satisfying "is_null" in the case of an
+           uninitialised tail call point.  See the comment in the C code. *)
+        external callee_node : t -> node
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_callee_node" "noalloc"
+
+        external next : t -> foreign_node
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_next" "noalloc"
+
+        let next t =
+          let next = next t in
+          if foreign_node_is_null next then None
+          else Some next
+      end
+
+      external callees : ocaml_node -> int -> Callee.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_indirect_call_point_callees"
+          "noalloc"
+
+      let callees t =
+        let callees = callees t.node t.offset in
+        if Callee.is_null callees then None
+        else Some callees
+    end
+
+    module Field = struct
+      type t = field_iterator
+
+      type direct_call_point =
+        | To_ocaml of ocaml_node Direct_call_point.t
+        | To_foreign of foreign_node Direct_call_point.t
+        | To_uninstrumented of
+            uninstrumented_node Direct_call_point.t
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Direct_call of direct_call_point
+        | Indirect_call of Indirect_call_point.t
+
+      external classify_direct_call_point : ocaml_node -> int -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_classify_direct_call_point"
+          "noalloc"
+
+      let classify t =
+        match t.part_of_shape with
+        | Shape_table.Direct_call callee ->
+          let direct_call_point =
+            match classify_direct_call_point t.node t.offset with
+            | 0 ->
+              (* We should never classify uninitialised call points here. *)
+              assert false
+            | 1 -> To_ocaml t
+            | 2 -> To_foreign t
+            | _ -> assert false
+          in
+          Direct_call direct_call_point
+        | Shape_table.Indirect_call _ -> Indirect_call t
+        | Shape_table.Allocation_point _ -> Allocation t
+
+      (* CR-soon mshinwell: change to "is_unused"? *)
+      let is_uninitialised t =
+        let offset_to_node_hole =
+          match t.part_of_shape with
+          | Shape_table.Direct_call _ -> Some 0
+          | Shape_table.Indirect_call _ -> Some 0
+          | Shape_table.Allocation_point _ -> None
+        in
+        match offset_to_node_hole with
+        | None -> false
+        | Some offset_to_node_hole ->
+          (* There are actually two cases:
+             1. A normal unused node hole, which says Val_unit;
+             2. An unused tail call point.  This will contain a pointer to the
+                start of the current node, but it also has the bottom bit
+                set. *)
+          let offset = t.offset + offset_to_node_hole in
+          Obj.is_int (Obj.field (Obj.repr t.node) offset)
+
+      let rec next t =
+        match t.remaining_layout with
+        | [] -> None
+        | part_of_shape::remaining_layout ->
+          let size = Shape_table.part_of_shape_size t.part_of_shape in
+          let offset = t.offset + size in
+          assert (offset < Obj.size (Obj.repr t.node));
+          let t =
+            { node = t.node;
+              offset;
+              part_of_shape;
+              remaining_layout;
+              shape_table = t.shape_table;
+            }
+          in
+          skip_uninitialised t
+
+      and skip_uninitialised t =
+        if not (is_uninitialised t) then Some t
+        else next t
+    end
+
+    module Node = struct
+      type t = ocaml_node
+
+      external function_identifier : t -> Function_identifier.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_function_identifier"
+
+      external next_in_tail_call_chain : t -> t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_tail_chain" "noalloc"
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+
+      let fields t ~shape_table =
+        match Shape_table.find_exn (function_identifier t) shape_table with
+        | exception Not_found -> None
+        | [] -> None
+        | part_of_shape::remaining_layout ->
+          let t =
+            { node = t;
+              offset = Lazy.force num_header_words;
+              part_of_shape;
+              remaining_layout;
+              shape_table;
+            }
+          in
+          Field.skip_uninitialised t
+    end
+  end
+
+  module Foreign = struct
+    module Node = struct
+      type t = foreign_node
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+
+      let fields t =
+        if foreign_node_is_null t then None
+        else Some t
+    end
+
+    module Allocation_point = struct
+      type t = foreign_node
+
+      external program_counter : t -> Program_counter.Foreign.t
+        (* This is not a mistake; the same C function works. *)
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_call_site"
+
+      external annotation : t -> Annotation.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_profinfo" "noalloc"
+
+      external num_words_including_headers : t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_allocation_count" "noalloc"
+    end
+
+    module Call_point = struct
+      type t = foreign_node
+
+      external call_site : t -> Program_counter.Foreign.t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_call_site"
+
+      (* May return a null node.  See comment above and the C code. *)
+      external callee_node : t -> node
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_callee_node" "noalloc"
+    end
+
+    module Field = struct
+      type t = foreign_node
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Call of Call_point.t
+
+      external is_call : t -> bool
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_is_call" "noalloc"
+
+      let classify t =
+        if is_call t then Call t
+        else Allocation t
+
+      external next : t -> t
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_c_node_next" "noalloc"
+
+      let next t =
+        let next = next t in
+        if foreign_node_is_null next then None
+        else Some next
+    end
+  end
+
+  module Node = struct
+    module T = struct
+      type t = node
+
+      external compare : t -> t -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_compare_node" "noalloc"
+    end
+
+    include T
+
+    type classification =
+      | OCaml of OCaml.Node.t
+      | Foreign of Foreign.Node.t
+
+    (* CR-soon lwhite: These functions should work in bytecode *)
+    external is_ocaml_node : t -> bool
+      = "caml_spacetime_only_works_for_native_code"
+        "caml_spacetime_is_ocaml_node" "noalloc"
+
+    let classify t =
+      if is_ocaml_node t then OCaml ((Obj.magic t) : ocaml_node)
+      else Foreign ((Obj.magic t) : foreign_node)
+
+    let of_ocaml_node (node : ocaml_node) : t = Obj.magic node
+    let of_foreign_node (node : foreign_node) : t = Obj.magic node
+
+    module Map = Map.Make (T)
+    module Set = Set.Make (T)
+  end
+
+  let root t = t
+end
+
+module Heap_snapshot = struct
+
+  module Entries = struct
+    type t = int array  (* == "struct snapshot_entries" *)
+
+    let length t =
+      let length = Array.length t in
+      assert (length mod 3 = 0);
+      length / 3
+
+    let annotation t idx = t.(idx*3)
+    let num_blocks t idx = t.(idx*3 + 1)
+    let num_words_including_headers t idx = t.(idx*3 + 2)
+  end
+
+  type total_allocations =
+    | End
+    | Total of {
+        annotation : Annotation.t;
+        count : int;
+        next : total_allocations;
+      }
+
+  let (_ : total_allocations) =  (* suppress compiler warning *)
+    Total { annotation = 0; count = 0; next = End; }
+
+  type t = {
+    timestamp : float;
+    gc_stats : Gc_stats.t;
+    entries : Entries.t;
+    words_scanned : int;
+    words_scanned_with_profinfo : int;
+    total_allocations : total_allocations;
+  }
+
+  type heap_snapshot = t
+
+  let timestamp t = t.timestamp
+  let gc_stats t = t.gc_stats
+  let entries t = t.entries
+  let words_scanned t = t.words_scanned
+  let words_scanned_with_profinfo t = t.words_scanned_with_profinfo
+
+  module Total_allocation = struct
+    type t = total_allocations  (* [End] is forbidden *)
+
+    let annotation = function
+      | End -> assert false
+      | Total { annotation; _ } -> annotation
+
+    let num_words_including_headers = function
+      | End -> assert false
+      | Total { count; _ } -> count
+
+    let next = function
+      | End -> assert false
+      | Total { next = End; _ } -> None
+      | Total { next; _ } -> Some next
+  end
+
+  let total_allocations t =
+    match t.total_allocations with
+    | End -> None
+    | (Total _) as totals -> Some totals
+
+  module Event = struct
+    type t = {
+      event_name : string;
+      time : float;
+    }
+
+    let event_name t = t.event_name
+    let timestamp t = t.time
+  end
+
+  module Series = struct
+    type t = {
+      num_snapshots : int;
+      time_of_writer_close : float;
+      frame_table : Frame_table.t;
+      shape_table : Shape_table.t;
+      traces_by_thread : Trace.t array;
+      finaliser_traces_by_thread : Trace.t array;
+      snapshots : heap_snapshot array;
+      events : Event.t list;
+    }
+
+    let pathname_suffix_trace = "trace"
+
+    (* The order of these constructors must match the C code. *)
+    type what_comes_next =
+      | Snapshot
+      | Traces
+      | Event
+
+    (* Suppress compiler warning 37. *)
+    let _ : what_comes_next list = [Snapshot; Traces; Event;]
+
+    let rec read_snapshots_and_events chn snapshots events =
+      let next : what_comes_next = Marshal.from_channel chn in
+      match next with
+      | Snapshot ->
+        let snapshot : heap_snapshot = Marshal.from_channel chn in
+        read_snapshots_and_events chn (snapshot :: snapshots) events
+      | Event ->
+        let event_name : string = Marshal.from_channel chn in
+        let time : float = Marshal.from_channel chn in
+        let event = { Event. event_name; time; } in
+        read_snapshots_and_events chn snapshots (event :: events)
+      | Traces ->
+        (Array.of_list (List.rev snapshots)), List.rev events
+
+    let read ~path =
+      let chn = open_in path in
+      let magic_number : int = Marshal.from_channel chn in
+      let magic_number_base = magic_number land 0xffff_ffff in
+      let version_number = magic_number lsr 32 in
+      if magic_number_base <> 0xace00ace then begin
+        failwith "Raw_spacetime_lib: not a Spacetime profiling file"
+      end else begin
+        match version_number with
+        | 0 ->
+          let snapshots, events = read_snapshots_and_events chn [] [] in
+          let num_snapshots = Array.length snapshots in
+          let time_of_writer_close : float = Marshal.from_channel chn in
+          let frame_table = Frame_table.demarshal chn in
+          let shape_table = Shape_table.demarshal chn in
+          let num_threads : int = Marshal.from_channel chn in
+          let traces_by_thread = Array.init num_threads (fun _ -> None) in
+          let finaliser_traces_by_thread =
+            Array.init num_threads (fun _ -> None)
+          in
+          for thread = 0 to num_threads - 1 do
+            let trace : Trace.t = Trace.unmarshal chn in
+            let finaliser_trace : Trace.t = Trace.unmarshal chn in
+            traces_by_thread.(thread) <- trace;
+            finaliser_traces_by_thread.(thread) <- finaliser_trace
+          done;
+          close_in chn;
+          { num_snapshots;
+            time_of_writer_close;
+            frame_table;
+            shape_table;
+            traces_by_thread;
+            finaliser_traces_by_thread;
+            snapshots;
+            events;
+          }
+        | _ ->
+          failwith "Raw_spacetime_lib: unknown Spacetime profiling file \
+            version number"
+      end
+
+    type trace_kind = Normal | Finaliser
+
+    let num_threads t = Array.length t.traces_by_thread
+
+    let trace t ~kind ~thread_index =
+      if thread_index < 0 || thread_index >= num_threads t then None
+      else
+        match kind with
+        | Normal -> Some t.traces_by_thread.(thread_index)
+        | Finaliser -> Some t.finaliser_traces_by_thread.(thread_index)
+
+    let num_snapshots t = t.num_snapshots
+    let snapshot t ~index = t.snapshots.(index)
+    let frame_table t = t.frame_table
+    let shape_table t = t.shape_table
+    let time_of_writer_close t = t.time_of_writer_close
+    let events t = t.events
+  end
+end

diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
new file mode 100644 (file)
index 0000000..51bbc91
--- /dev/null
+++ b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
@@ -0,0 +1,349 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Access to the information recorded by the [Spacetime]
+    module.  (It is intended that this module will be used by
+    post-processors rather than users wishing to understand their
+    programs.)
+    For 64-bit targets only.
+    This module may be used from any program, not just one compiled
+    with a compiler configured for Spacetime. *)
+
+module Gc_stats : sig
+  type t
+
+  val minor_words : t -> int
+  val promoted_words : t -> int
+  val major_words : t -> int
+  val minor_collections : t -> int
+  val major_collections : t -> int
+  val heap_words : t -> int
+  val heap_chunks : t -> int
+  val compactions : t -> int
+  val top_heap_words : t -> int
+end
+
+module Annotation : sig
+  (** An annotation written into a value's header.  These may be looked up
+      in a [Trace.t] (see below). *)
+  type t
+
+  (* CR-someday mshinwell: consider using tag and size to increase the
+     available space of annotations.  Need to be careful of [Obj.truncate].
+     Could also randomise the tags on records.
+  *)
+
+  val to_int : t -> int
+end
+
+module Program_counter : sig
+  module OCaml : sig
+    type t
+
+    val to_int64 : t -> Int64.t
+  end
+
+  module Foreign : sig
+    type t
+
+    val to_int64 : t -> Int64.t
+  end
+
+end
+
+module Frame_table : sig
+  (* CR-someday mshinwell: move to [Gc] if dependencies permit? *)
+  (** A value of type [t] corresponds to the frame table of a running
+      OCaml program.  The table is indexed by program counter address
+      (typically, but not always when using Spacetime, return addresses). *)
+  type t
+
+  (** Find the location, including any inlined frames, corresponding to the
+      given program counter address.  Raises [Not_found] if the location
+      could not be resolved. *)
+  val find_exn : Program_counter.OCaml.t -> t -> Printexc.Slot.t list
+end
+
+module Function_entry_point : sig
+  type t
+
+  val to_int64 : t -> Int64.t
+end
+
+module Function_identifier : sig
+  type t
+  (* CR-soon mshinwell: same as [Function_entry_point] now *)
+  val to_int64 : t -> Int64.t
+end
+
+module Shape_table : sig
+  type t
+end
+
+module Trace : sig
+  (** A value of type [t] holds the dynamic call structure of the program
+      (i.e. which functions have called which other functions) together with
+      information required to decode profiling annotations written into
+      values' headers. *)
+  type t
+
+  type node
+  type ocaml_node
+  type foreign_node
+  type uninstrumented_node
+
+  module OCaml : sig
+    module Allocation_point : sig
+      (** A value of type [t] corresponds to an allocation point in OCaml
+          code. *)
+      type t
+
+      (** The program counter at (or close to) the allocation site. *)
+      val program_counter : t -> Program_counter.OCaml.t
+
+      (** The annotation written into the headers of boxed values allocated
+          at the given allocation site. *)
+      val annotation : t -> Annotation.t
+
+      (** The total number of words allocated at this point. *)
+      val num_words_including_headers : t -> int
+    end
+
+    module Direct_call_point : sig
+      (** A value of type ['target t] corresponds to a direct (i.e. known
+          at compile time) call point in OCaml code.  ['target] is the type
+          of the node corresponding to the callee. *)
+      type 'target t
+
+      (** The program counter at (or close to) the call site. *)
+      val call_site : _ t -> Program_counter.OCaml.t
+
+      (** The address of the first instruction of the callee. *)
+      val callee : _ t -> Function_entry_point.t
+
+      (** The node corresponding to the callee. *)
+      val callee_node : 'target t -> 'target
+    end
+
+    module Indirect_call_point : sig
+      (** A value of type [t] corresponds to an indirect call point in OCaml
+          code.  Each such value contains a list of callees to which the
+          call point has branched. *)
+      type t
+
+      (** The program counter at (or close to) the call site. *)
+      val call_site : t -> Program_counter.OCaml.t
+
+      module Callee : sig
+        type t
+
+        (** The address of the first instruction of the callee. *)
+        val callee : t -> Function_entry_point.t
+
+        (** The node corresponding to the callee. *)
+        val callee_node : t -> node
+
+        (** Move to the next callee to which this call point has branched.
+            [None] is returned when the end of the list is reached. *)
+        val next : t -> t option
+      end
+
+      (** The list of callees to which this indirect call point has
+          branched. *)
+      val callees : t -> Callee.t option
+    end
+
+    module Field : sig
+      (** A value of type [t] enables iteration through the contents
+          ("fields") of an OCaml node. *)
+      type t
+
+      type direct_call_point =
+        | To_ocaml of ocaml_node Direct_call_point.t
+        | To_foreign of foreign_node Direct_call_point.t
+        (* CR-soon mshinwell: once everything's finished, "uninstrumented"
+           should be able to go away.  Let's try to do this after the
+           first release. *)
+        | To_uninstrumented of
+            uninstrumented_node Direct_call_point.t
+
+      type classification =
+        | Allocation of Allocation_point.t
+        | Direct_call of direct_call_point
+        | Indirect_call of Indirect_call_point.t
+
+      val classify : t -> classification
+      val next : t -> t option
+    end
+
+    module Node : sig
+      (** A node corresponding to an invocation of a function written in
+          OCaml. *)
+      type t = ocaml_node
+
+      val compare : t -> t -> int
+
+      (** A unique identifier for the function corresponding to this node. *)
+      val function_identifier : t -> Function_identifier.t
+
+      (** This function traverses a circular list. *)
+      val next_in_tail_call_chain : t -> t
+
+      val fields : t -> shape_table:Shape_table.t -> Field.t option
+    end
+  end
+
+  module Foreign : sig
+    module Allocation_point : sig
+      (** A value of type [t] corresponds to an allocation point in non-OCaml
+          code. *)
+      type t
+
+      val program_counter : t -> Program_counter.Foreign.t
+      val annotation : t -> Annotation.t
+      val num_words_including_headers : t -> int
+    end
+
+    module Call_point : sig
+      (** A value of type [t] corresponds to a call point from non-OCaml
+          code (to either non-OCaml code, or OCaml code via the usual
+          assembly veneer). *)
+      type t
+
+      (** N.B. The address of the callee (of type [Function_entry_point.t]) is
+          not available.  It must be recovered during post-processing. *)
+      val call_site : t -> Program_counter.Foreign.t
+      val callee_node : t -> node
+    end
+
+    module Field : sig
+      (** A value of type [t] enables iteration through the contents ("fields")
+          of a C node. *)
+      type t
+
+      type classification = private
+        | Allocation of Allocation_point.t
+        | Call of Call_point.t
+
+      val classify : t -> classification
+      val next : t -> t option
+    end
+
+    module Node : sig
+      (** A node corresponding to an invocation of a function written in C
+          (or any other language that is not OCaml). *)
+      type t = foreign_node
+
+      val compare : t -> t -> int
+
+      val fields : t -> Field.t option
+
+    end
+
+  end
+
+  module Node : sig
+    (** Either an OCaml or a foreign node; or an indication that this
+        is a branch of the graph corresponding to uninstrumented
+        code. *)
+    type t = node
+
+    val compare : t -> t -> int
+
+    type classification = private
+      | OCaml of OCaml.Node.t
+      | Foreign of Foreign.Node.t
+
+    val classify : t -> classification
+
+    val of_ocaml_node : OCaml.Node.t -> t
+    val of_foreign_node : Foreign.Node.t -> t
+
+    module Set : Set.S with type elt = t
+    module Map : Map.S with type key = t
+  end
+
+  (** Obtains the root of the graph for traversal.  [None] is returned if
+      the graph is empty. *)
+  val root : t -> Node.t option
+end
+
+module Heap_snapshot : sig
+  type t
+  type heap_snapshot = t
+
+  module Entries : sig
+    (** An immutable array of the total number of blocks (= boxed
+        values) and the total number of words occupied by such blocks
+        (including their headers) for each profiling annotation in
+        the heap. *)
+    type t
+
+    val length : t -> int
+    val annotation : t -> int -> Annotation.t
+    val num_blocks : t -> int -> int
+    val num_words_including_headers : t -> int -> int
+
+  end
+
+  (** The timestamp of a snapshot.  The units are as for [Sys.time]
+      (unless custom timestamps are being provided, cf. the [Spacetime] module
+      in the standard library). *)
+  val timestamp : t -> float
+
+  val gc_stats : t -> Gc_stats.t
+  val entries : t -> Entries.t
+  val words_scanned : t -> int
+  val words_scanned_with_profinfo : t -> int
+
+  module Total_allocation : sig
+    type t
+
+    val annotation : t -> Annotation.t
+    val num_words_including_headers : t -> int
+    val next : t -> t option
+  end
+  (** Total allocations across *all threads*. *)
+  (* CR-someday mshinwell: change the relevant variables to be thread-local *)
+  val total_allocations : t -> Total_allocation.t option
+
+  module Event : sig
+    type t
+
+    val event_name : t -> string
+    val timestamp : t -> float
+  end
+
+  module Series : sig
+    type t
+
+    (** At present, the [Trace.t] associated with a [Series.t] cannot be
+        garbage collected or freed.  This should not be a problem, since
+        the intention is that a post-processor reads the trace and outputs
+        another format. *)
+    val read : path:string -> t
+
+    val time_of_writer_close : t -> float
+    val num_threads : t -> int
+
+    type trace_kind = Normal | Finaliser
+    val trace : t -> kind:trace_kind -> thread_index:int -> Trace.t option
+
+    val frame_table : t -> Frame_table.t
+    val shape_table : t -> Shape_table.t
+    val num_snapshots : t -> int
+    val snapshot : t -> index:int -> heap_snapshot
+    val events : t -> Event.t list
+  end
+end

diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend
index 53483c9c51d5c9672c875cc574eb3c1b0db7ed1e..6625198e61a3c975e0cfd63a37948ba472bfe565 100644 (file)
--- a/otherlibs/str/.depend
+++ b/otherlibs/str/.depend
@@ -2,9 +2,7 @@ strstubs.o: strstubs.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h ../../byterun/caml/fail.h
-str.cmi :
+  ../../byterun/caml/fail.h
 str.cmo : str.cmi
 str.cmx : str.cmi
+str.cmi :

diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile
index 82685f107c6bf4e2fa17a3a7b5309e143ecae95f..7ab2f11f7334d1ca894257ecd73eed2ba0ba8f95 100644 (file)
--- a/otherlibs/str/Makefile
+++ b/otherlibs/str/Makefile
@@ -13,23 +13,4 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the str library
-
-
-LIBNAME=str
-COBJS=strstubs.$(O)
-CLIBNAME=camlstr
-CAMLOBJS=str.cmo
-
-include ../Makefile
-
-depend:
-
-str.cmo: str.cmi
-str.cmx: str.cmi
-
-depend:
-       $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
-
-include .depend
+include Makefile.shared

diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt
index 908a3f1ee099ca203683103fa1b23e97740ea95c..202a3cb85fd6ef389f80d16057133739c0e85a16 100644 (file)
--- a/otherlibs/str/Makefile.nt
+++ b/otherlibs/str/Makefile.nt
@@ -13,16 +13,9 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the str library
+include Makefile.shared
 
-LIBNAME=str
-COBJS=strstubs.$(O)
-CLIBNAME=camlstr
-CAMLOBJS=str.cmo
+.depend.nt: .depend
+       sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
 
-include ../Makefile.nt
-
-depend:
-
-str.cmo: str.cmi
-str.cmx: str.cmi
+include .depend.nt

diff --git a/otherlibs/str/Makefile.shared b/otherlibs/str/Makefile.shared
new file mode 100644 (file)
index 0000000..b501030
--- /dev/null
+++ b/otherlibs/str/Makefile.shared
@@ -0,0 +1,32 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
+#*                                                                        *
+#*   Copyright 1999 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Makefile for the str library
+
+LIBNAME=str
+COBJS=strstubs.$(O)
+CLIBNAME=camlstr
+CAMLOBJS=str.cmo
+
+include ../Makefile
+
+str.cmo: str.cmi
+str.cmx: str.cmi
+
+depend:
+       $(CC) -MM $(CFLAGS) *.c > .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+
+include .depend

diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
index b74cee0c268e96b96c54bfee35172fa8f7ab9682..63c197150e97ef914b42d49e5e5f3b69d4a6b461 100644 (file)
--- a/otherlibs/str/str.ml
+++ b/otherlibs/str/str.ml
@@ -163,16 +163,16 @@ let displ dest from = dest - from - 1
 (* Determine if a regexp can match the empty string *)
 
 let rec is_nullable = function
-    Char c -> false
+    Char _ -> false
   | String s -> s = ""
-  | CharClass(cl, cmpl) -> false
+  | CharClass _ -> false
   | Seq rl -> List.for_all is_nullable rl
   | Alt (r1, r2) -> is_nullable r1 || is_nullable r2
-  | Star r -> true
+  | Star _ -> true
   | Plus r -> is_nullable r
-  | Option r -> true
-  | Group(n, r) -> is_nullable r
-  | Refgroup n -> true
+  | Option _ -> true
+  | Group(_, r) -> is_nullable r
+  | Refgroup _ -> true
   | Bol -> true
   | Eol -> true
   | Wordboundary -> true
@@ -187,11 +187,11 @@ let rec first = function
   | CharClass(cl, cmpl) -> if cmpl then Charset.complement cl else cl
   | Seq rl -> first_seq rl
   | Alt (r1, r2) -> Charset.union (first r1) (first r2)
-  | Star r -> Charset.full
+  | Star _ -> Charset.full
   | Plus r -> first r
-  | Option r -> Charset.full
-  | Group(n, r) -> first r
-  | Refgroup n -> Charset.full
+  | Option _ -> Charset.full
+  | Group(_, r) -> first r
+  | Refgroup _ -> Charset.full
   | Bol -> Charset.full
   | Eol -> Charset.full
   | Wordboundary -> Charset.full
@@ -201,7 +201,7 @@ and first_seq = function
   | (Bol | Eol | Wordboundary) :: rl -> first_seq rl
   | Star r :: rl -> Charset.union (first r) (first_seq rl)
   | Option r :: rl -> Charset.union (first r) (first_seq rl)
-  | r :: rl -> first r
+  | r :: _ -> first r
 
 (* Transform a Char or CharClass regexp into a character class *)
 

diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend
index 03da2d853d9eecad4c9f30fcdf91ee1687a61092..5181e939d281821a97b7c6e13472913c016622e0 100644 (file)
--- a/otherlibs/systhreads/.depend
+++ b/otherlibs/systhreads/.depend
@@ -11,18 +11,18 @@ st_stubs.o: st_stubs.c ../../byterun/caml/alloc.h \
   ../../byterun/caml/printexc.h ../../byterun/caml/roots.h \
   ../../byterun/caml/signals.h ../../byterun/caml/stacks.h \
   ../../byterun/caml/sys.h threads.h st_posix.h
-condition.cmi : mutex.cmi
-event.cmi :
-mutex.cmi :
-thread.cmi :
-threadUnix.cmi :
 condition.cmo : mutex.cmi condition.cmi
 condition.cmx : mutex.cmx condition.cmi
+condition.cmi : mutex.cmi
 event.cmo : mutex.cmi condition.cmi event.cmi
 event.cmx : mutex.cmx condition.cmx event.cmi
+event.cmi :
 mutex.cmo : mutex.cmi
 mutex.cmx : mutex.cmi
+mutex.cmi :
 thread.cmo : thread.cmi
 thread.cmx : thread.cmi
+thread.cmi :
 threadUnix.cmo : thread.cmi threadUnix.cmi
 threadUnix.cmx : thread.cmx threadUnix.cmi
+threadUnix.cmi :

diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile
index 1091e23254f2f0922e45cd9eebbc03884a0fe205..87e071a60e79f5ae27e5954b147f4a5ba93f8c70 100644 (file)
--- a/otherlibs/systhreads/Makefile
+++ b/otherlibs/systhreads/Makefile
@@ -117,6 +117,6 @@ installopt:
 
 depend: $(GENFILES)
        -$(CC) -MM -I../../byterun *.c > .depend
-       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend

diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt
index 48e3bdcd1a492f0116693b45b2cf495a4359c5fe..e1dd2c36f63b4a8f2fc28f7b90f7a51c1f4db4b2 100644 (file)
--- a/otherlibs/systhreads/Makefile.nt
+++ b/otherlibs/systhreads/Makefile.nt
@@ -35,8 +35,8 @@ else
   export OCAML_FLEXLINK:=../../boot/ocamlrun ../../flexdll/flexlink.exe
 endif
 
-CAMLOBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
-CMIFILES=$(CAMLOBJS:.cmo=.cmi)
+THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo
+CMIFILES=$(THREAD_OBJS:.cmo=.cmi)
 COBJS=st_stubs_b.$(O)
 COBJS_NAT=st_stubs_n.$(O)
 
@@ -46,9 +46,9 @@ all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES)
 
 allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES)
 
-$(LIBNAME).cma: $(CAMLOBJS)
+$(LIBNAME).cma: $(THREAD_OBJS)
        $(MKLIB) -o $(LIBNAME) -ocamlc "$(CAMLRUN) ../../ocamlc" \
-                -linkall $(CAMLOBJS) $(LINKOPTS)
+                -linkall $(THREAD_OBJS) $(LINKOPTS)
 
 lib$(LIBNAME).$(A): $(COBJS)
        $(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS)
@@ -59,10 +59,10 @@ st_stubs_b.$(O): st_stubs.c st_win32.h
 
 
 
-$(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx)
+$(LIBNAME).cmxa: $(THREAD_OBJS:.cmo=.cmx)
        $(MKLIB) -o $(LIBNAME)nat \
                 -ocamlopt "$(CAMLRUN) ../../ocamlopt" -linkall \
-                $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS)
+                $(THREAD_OBJS:.cmo=.cmx) $(LINKOPTS)
        mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa
        mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A)
 
@@ -77,7 +77,7 @@ st_stubs_n.$(O): st_stubs.c st_win32.h
                    $(NATIVECCCOMPOPTS) -c st_stubs.c
        mv st_stubs.$(O) st_stubs_n.$(O)
 
-$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt
+$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt
 
 partialclean:
        rm -f *.cm*

diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h
index cfa3f6f359d35c028d64d95ea9460bb249d6a417..4e4ee19b75c8c58338287e13c5b4c62ea71957a6 100644 (file)
--- a/otherlibs/systhreads/st_posix.h
+++ b/otherlibs/systhreads/st_posix.h
@@ -420,7 +420,7 @@ value caml_wait_signal(value sigs) /* ML */
   retcode = sigwait(&set, &signo);
   leave_blocking_section();
   st_check_error(retcode, "Thread.wait_signal");
-  return Val_int(signo);
+  return Val_int(caml_rev_convert_signal_number(signo));
 #else
   invalid_argument("Thread.wait_signal not implemented");
   return Val_int(0);            /* not reached */

diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c
index dd7f3f5d0911d4b425407534cd238475d0126d8d..9c91e00c9f21d4e457668681a23d1fe5b62b79f4 100644 (file)
--- a/otherlibs/systhreads/st_stubs.c
+++ b/otherlibs/systhreads/st_stubs.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include "caml/alloc.h"
 #include "caml/backtrace.h"
 #include "caml/callback.h"
@@ -26,13 +28,17 @@
 #include "caml/roots.h"
 #include "caml/signals.h"
 #ifdef NATIVE_CODE
-#include "stack.h"
+#include "caml/stack.h"
 #else
 #include "caml/stacks.h"
 #endif
 #include "caml/sys.h"
 #include "threads.h"
 
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+#include "../../asmrun/spacetime.h"
+#endif
+
 /* Initial size of bytecode stack when a thread is created (4 Ko) */
 #define Thread_stack_size (Stack_size / 4)
 
@@ -72,6 +78,12 @@ struct caml_thread_struct {
   char * exception_pointer;     /* Saved value of caml_exception_pointer */
   struct caml__roots_block * local_roots; /* Saved value of local_roots */
   struct longjmp_buffer * exit_buf; /* For thread exit */
+#if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
+  value internal_spacetime_trie_root;
+  value internal_spacetime_finaliser_trie_root;
+  value* spacetime_trie_node_ptr;
+  value* spacetime_finaliser_trie_root;
+#endif
 #else
   value * stack_low;            /* The execution stack for this thread */
   value * stack_high;
@@ -162,6 +174,12 @@ static inline void caml_thread_save_runtime_state(void)
   curr_thread->gc_regs = caml_gc_regs;
   curr_thread->exception_pointer = caml_exception_pointer;
   curr_thread->local_roots = local_roots;
+#ifdef WITH_SPACETIME
+  curr_thread->spacetime_trie_node_ptr
+    = caml_spacetime_trie_node_ptr;
+  curr_thread->spacetime_finaliser_trie_root
+    = caml_spacetime_finaliser_trie_root;
+#endif
 #else
   curr_thread->stack_low = stack_low;
   curr_thread->stack_high = stack_high;
@@ -184,6 +202,12 @@ static inline void caml_thread_restore_runtime_state(void)
   caml_gc_regs = curr_thread->gc_regs;
   caml_exception_pointer = curr_thread->exception_pointer;
   local_roots = curr_thread->local_roots;
+#ifdef WITH_SPACETIME
+  caml_spacetime_trie_node_ptr
+    = curr_thread->spacetime_trie_node_ptr;
+  caml_spacetime_finaliser_trie_root
+    = curr_thread->spacetime_finaliser_trie_root;
+#endif
 #else
   stack_low = curr_thread->stack_low;
   stack_high = curr_thread->stack_high;
@@ -316,6 +340,20 @@ static caml_thread_t caml_thread_new_info(void)
   th->exception_pointer = NULL;
   th->local_roots = NULL;
   th->exit_buf = NULL;
+#ifdef WITH_SPACETIME
+  /* CR-someday mshinwell: The commented-out changes here are for multicore,
+     where we think we should have one trie per domain. */
+  th->internal_spacetime_trie_root = Val_unit;
+  th->spacetime_trie_node_ptr =
+    &caml_spacetime_trie_root; /* &th->internal_spacetime_trie_root; */
+  th->internal_spacetime_finaliser_trie_root = Val_unit;
+  th->spacetime_finaliser_trie_root
+    = caml_spacetime_finaliser_trie_root;
+    /* &th->internal_spacetime_finaliser_trie_root; */
+  caml_spacetime_register_thread(
+    th->spacetime_trie_node_ptr,
+    th->spacetime_finaliser_trie_root);
+#endif
 #else
   /* Allocate the stacks */
   th->stack_low = (value *) caml_stat_alloc(Thread_stack_size);
@@ -366,7 +404,13 @@ static void caml_thread_remove_info(caml_thread_t th)
   stat_free(th->stack_low);
 #endif
   if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
+#ifndef WITH_SPACETIME
   stat_free(th);
+  /* CR-soon mshinwell: consider what to do about the Spacetime trace.  Could
+     perhaps have a hook to save a snapshot on thread termination.
+     For the moment we can't even free [th], since it contains the trie
+     roots. */
+#endif
 }
 
 /* Reinitialize the thread machinery after a fork() (PR#4577) */

diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
index b425264d69786519238b53bbfc3cbd818cf46765..741d4253a196f16da231dc6d006f8e9622ae78e1 100644 (file)
--- a/otherlibs/threads/.depend
+++ b/otherlibs/threads/.depend
@@ -10,24 +10,24 @@ scheduler.o: scheduler.c ../../byterun/caml/alloc.h \
   ../../byterun/caml/address_class.h ../../byterun/caml/printexc.h \
   ../../byterun/caml/roots.h ../../byterun/caml/signals.h \
   ../../byterun/caml/stacks.h ../../byterun/caml/sys.h
-condition.cmi : mutex.cmi
-event.cmi :
-mutex.cmi :
-thread.cmi : unix.cmo
-threadUnix.cmi : unix.cmo
 condition.cmo : thread.cmi mutex.cmi condition.cmi
 condition.cmx : thread.cmx mutex.cmx condition.cmi
+condition.cmi : mutex.cmi
 event.cmo : mutex.cmi condition.cmi event.cmi
 event.cmx : mutex.cmx condition.cmx event.cmi
+event.cmi :
 marshal.cmo :
 marshal.cmx :
 mutex.cmo : thread.cmi mutex.cmi
 mutex.cmx : thread.cmx mutex.cmi
+mutex.cmi :
 pervasives.cmo : unix.cmo
 pervasives.cmx : unix.cmx
 thread.cmo : unix.cmo thread.cmi
 thread.cmx : unix.cmx thread.cmi
+thread.cmi : unix.cmo
 threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi
 threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi
+threadUnix.cmi : unix.cmo
 unix.cmo :
 unix.cmx :

diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
index 729c444e8ee4296cfef9f93d6ab438c8758b6d36..dbe02504276a3703b893448ff5619c59efbc1bb1 100644 (file)
--- a/otherlibs/threads/Makefile
+++ b/otherlibs/threads/Makefile
@@ -131,6 +131,6 @@ installopt:
 
 depend:
        $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend

diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index a497350a5f7323eed59148ec0d4a7bd2cf08fae9..fe3767d38fdc42c5c8d83274f198ff9e047f1d50 100644 (file)
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -189,14 +189,14 @@ external classify_float : (float [@unboxed]) -> fpclass =
 (* String and byte sequence operations -- more in modules String and Bytes *)
 
 external string_length : string -> int = "%string_length"
-external bytes_length : bytes -> int = "%string_length"
-external bytes_create : int -> bytes = "caml_create_string"
+external bytes_length : bytes -> int = "%bytes_length"
+external bytes_create : int -> bytes = "caml_create_bytes"
 external string_blit : string -> int -> bytes -> int -> int -> unit
                      = "caml_blit_string" [@@noalloc]
 external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
-                        = "caml_blit_string" [@@noalloc]
-external bytes_unsafe_to_string : bytes -> string = "%identity"
-external bytes_unsafe_of_string : string -> bytes = "%identity"
+                        = "caml_blit_bytes" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
+external bytes_unsafe_of_string : string -> bytes = "%bytes_of_string"
 
 let ( ^ ) s1 s2 =
   let l1 = string_length s1 and l2 = string_length s2 in
@@ -479,7 +479,7 @@ let really_input_string ic len =
   really_input ic s 0 len;
   bytes_unsafe_to_string s
 
-external bytes_set : bytes -> int -> char -> unit = "%string_safe_set"
+external bytes_set : bytes -> int -> char -> unit = "%bytes_safe_set"
 
 let input_line ic =
   let buf = ref (bytes_create 128) in

diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c
index 4fb9b1c30504b8fa3d8b50a2d50a963b82cfe124..f10bd4e77e3ff88fc97c5cfc0ccc931b44cbfa9f 100644 (file)
--- a/otherlibs/threads/scheduler.c
+++ b/otherlibs/threads/scheduler.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The thread scheduler */
 
 #include <string.h>

diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
index 7e7948803ed42208a3798df422f1a1fdcff6ff19..0076ca6db4f53cb3fa62fdc8adfe1a00004d92cf 100644 (file)
--- a/otherlibs/unix/.depend
+++ b/otherlibs/unix/.depend
@@ -3,27 +3,20 @@ accept.o: accept.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
 access.o: access.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h ../../byterun/caml/signals.h \
-  unixsupport.h
+  ../../byterun/caml/signals.h unixsupport.h
 addrofstr.o: addrofstr.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/fail.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/fail.h unixsupport.h \
+  socketaddr.h
 alarm.o: alarm.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -38,34 +31,22 @@ chdir.o: chdir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 chmod.o: chmod.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 chown.o: chown.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 chroot.o: chroot.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 close.o: close.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -75,10 +56,7 @@ closedir.o: closedir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 connect.o: connect.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -93,10 +71,7 @@ cstringv.o: cstringv.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 dup.o: dup.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -121,26 +96,17 @@ execv.o: execv.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 execve.o: execve.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 execvp.o: execvp.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 exit.o: exit.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -176,10 +142,8 @@ getaddrinfo.o: getaddrinfo.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h cst2constr.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  cst2constr.h socketaddr.h
 getcwd.o: getcwd.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -205,10 +169,7 @@ getgr.o: getgr.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/fail.h ../../byterun/caml/alloc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 getgroups.o: getgroups.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -219,10 +180,8 @@ gethost.o: gethost.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
 gethostname.o: gethostname.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -238,10 +197,8 @@ getnameinfo.o: getnameinfo.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
 getpeername.o: getpeername.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -262,28 +219,19 @@ getproto.o: getproto.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 getpw.o: getpw.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h ../../byterun/caml/fail.h \
-  unixsupport.h
+  ../../byterun/caml/fail.h unixsupport.h
 getserv.o: getserv.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 getsockname.o: getsockname.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -304,10 +252,7 @@ gmtime.o: gmtime.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 initgroups.o: initgroups.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -323,10 +268,7 @@ itimer.o: itimer.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 kill.o: kill.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -336,10 +278,7 @@ link.o: link.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 listen.o: listen.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -360,18 +299,12 @@ mkdir.o: mkdir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 mkfifo.o: mkfifo.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 nice.o: nice.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -382,18 +315,13 @@ open.o: open.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h ../../byterun/caml/signals.h \
-  unixsupport.h
+  ../../byterun/caml/signals.h unixsupport.h
 opendir.o: opendir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/signals.h unixsupport.h
 pipe.o: pipe.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -403,18 +331,12 @@ putenv.o: putenv.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 read.o: read.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 readdir.o: readdir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -425,19 +347,13 @@ readlink.o: readlink.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/signals.h unixsupport.h
 rename.o: rename.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 rewinddir.o: rewinddir.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -447,28 +363,20 @@ rmdir.o: rmdir.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 select.o: select.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 sendrecv.o: sendrecv.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
+  socketaddr.h
 setgid.o: setgid.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -479,10 +387,7 @@ setgroups.o: setgroups.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  unixsupport.h
+  ../../byterun/caml/memory.h unixsupport.h
 setsid.o: setsid.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
@@ -521,10 +426,8 @@ socketaddr.o: socketaddr.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h unixsupport.h socketaddr.h
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h unixsupport.h \
+  socketaddr.h
 socketpair.o: socketpair.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -534,11 +437,8 @@ sockopt.o: sockopt.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h \
-  socketaddr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
+  ../../byterun/caml/fail.h unixsupport.h socketaddr.h
 stat.o: stat.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -558,10 +458,7 @@ symlink.o: symlink.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 termios.o: termios.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -576,10 +473,7 @@ times.o: times.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \
-  ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \
-  ../../byterun/caml/address_class.h unixsupport.h
+  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h unixsupport.h
 truncate.o: truncate.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -599,26 +493,18 @@ unixsupport.o: unixsupport.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/callback.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/fail.h unixsupport.h cst2constr.h
+  ../../byterun/caml/memory.h ../../byterun/caml/fail.h unixsupport.h \
+  cst2constr.h
 unlink.o: unlink.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 utimes.o: utimes.c ../../byterun/caml/fail.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \
   ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 wait.o: wait.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
@@ -632,13 +518,10 @@ write.o: write.c ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \
   ../../byterun/caml/../../config/m.h \
   ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \
-  ../../byterun/caml/memory.h ../../byterun/caml/gc.h \
-  ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \
-  ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \
-  ../../byterun/caml/signals.h unixsupport.h
-unix.cmi :
-unixLabels.cmi : unix.cmi
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 unix.cmo : unix.cmi
 unix.cmx : unix.cmi
+unix.cmi :
 unixLabels.cmo : unix.cmi unixLabels.cmi
 unixLabels.cmx : unix.cmx unixLabels.cmi
+unixLabels.cmi : unix.cmi

diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
index e93696ea1a853aa89dad29907ccdb632bfc537bc..ce3fb74890080b457936f26a16ab65ecfcfc07cd 100644 (file)
--- a/otherlibs/unix/Makefile
+++ b/otherlibs/unix/Makefile
@@ -44,6 +44,6 @@ include ../Makefile
 
 depend:
        $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend

diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c
index bd174de52a447a63e455a93a8e0973e68b765425..c8fef37c0ca1f4f4db1b54ca6b384e3c4c176f27 100644 (file)
--- a/otherlibs/unix/fork.c
+++ b/otherlibs/unix/fork.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/debugger.h>
 #include "unixsupport.h"

diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c
index 8542786a859b0e2dac8aff8d72f6010b73d3a643..7c49f2d63cabd52abc64a738c612d37bbfce6dd3 100644 (file)
--- a/otherlibs/unix/ftruncate.c
+++ b/otherlibs/unix/ftruncate.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <sys/types.h>
 #include <caml/fail.h>
 #include <caml/mlvalues.h>

diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c
index 3593369b3977c1b4d8ae352f9297d34d2b9d8f3e..7177c18fdcf9ee3b20665c428c131e8a7116c328 100644 (file)
--- a/otherlibs/unix/kill.c
+++ b/otherlibs/unix/kill.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/fail.h>
 #include "unixsupport.h"

diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c
index d8978555af725b3d7b90d93289e0923742f427f1..4b3cad41cae3facb37f1f8e1d9e0d60b1f4b32c2 100644 (file)
--- a/otherlibs/unix/lseek.c
+++ b/otherlibs/unix/lseek.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <errno.h>
 #include <sys/types.h>
 #include <caml/mlvalues.h>

diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c
index d1fb3a085babc0c296c785b3f14b787cc145066e..a46e345ff0ee382fa78bd7e7717052eadc4521f6 100644 (file)
--- a/otherlibs/unix/signals.c
+++ b/otherlibs/unix/signals.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <errno.h>
 #include <signal.h>
 

diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c
index 1357d44c699bbaec6f4b8622f67ed4eeb2d2e063..5f1b66014387dcb2b164384f431128d47ffd9cff 100644 (file)
--- a/otherlibs/unix/sleep.c
+++ b/otherlibs/unix/sleep.c
@@ -30,8 +30,8 @@
 CAMLprim value unix_sleep(value duration)
 {
   double d = Double_val(duration);
-  if (d <= 0.0) return Val_unit;
-#if _POSIX_C_SOURCE >= 199309L
+  if (d < 0.0) return Val_unit;
+#if defined(HAS_NANOSLEEP)
   {
     struct timespec t;
     int ret;

diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c
index e2a8f6a9e6278001f2e1dabaf56561d08fb2f381..6cde064e2af4664e1a79f4504d4e0b7af1cefee4 100644 (file)
--- a/otherlibs/unix/stat.c
+++ b/otherlibs/unix/stat.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <errno.h>
 #include <sys/types.h>
 #include <sys/stat.h>

diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c
index 4daba78a123ed411929bcc6de49a5de97bb79530..d2c6f125ace6d6e7e1214ed6231cf6c8a08e5f30 100644 (file)
--- a/otherlibs/unix/truncate.c
+++ b/otherlibs/unix/truncate.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <sys/types.h>
 #include <caml/mlvalues.h>
 #include <caml/memory.h>

diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index e345e9bb8277e2497e1094bfa842b64b3bca88df..420ee0270103eb2bc10f03bec21fdacab2a455c3 100644 (file)
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -1077,7 +1077,7 @@ let establish_server server_fun sockaddr =
   bind sock sockaddr;
   listen sock 5;
   while true do
-    let (s, caller) = accept_non_intr sock in
+    let (s, _caller) = accept_non_intr sock in
     (* The "double fork" trick, the process which calls server_fun will not
        leave a zombie process *)
     match fork() with

diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index cfec2cb6d698c52084980c112ef393fe913f426f..abb570e6d35fd949e9b7a71b522ca9c615e2c590 100644 (file)
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -716,9 +716,7 @@ val has_symlink : unit -> bool
    simply indicates that the symlink system call is available. *)
 
 val readlink : string -> string
-(** Read the contents of a link.
-
-   On Windows: not implemented. *)
+(** Read the contents of a symbolic link. *)
 
 
 (** {6 Polling} *)
@@ -882,7 +880,9 @@ val sleep : int -> unit
 
 val sleepf : float -> unit
 (** Stop execution for the given number of seconds.  Like [sleep],
-    but fractions of seconds are supported. *)
+    but fractions of seconds are supported.
+
+    @since 4.03.0 *)
 
 val times : unit -> process_times
 (** Return the execution times of the process.
@@ -1066,9 +1066,8 @@ type socket_domain =
   | PF_INET                     (** Internet domain (IPv4) *)
   | PF_INET6                    (** Internet domain (IPv6) *)
 (** The type of socket domains.  Not all platforms support
-    IPv6 sockets (type [PF_INET6]).
-    On Windows, the domains [PF_UNIX] and [PF_INET6] are not
-    supported; [PF_INET] is fully supported. *)
+    IPv6 sockets (type [PF_INET6]).  Windows does not support
+    [PF_UNIX]. *)
 
 type socket_type =
     SOCK_STREAM                 (** Stream socket *)
@@ -1076,7 +1075,9 @@ type socket_type =
   | SOCK_RAW                    (** Raw socket *)
   | SOCK_SEQPACKET              (** Sequenced packets socket *)
 (** The type of socket kinds, specifying the semantics of
-   communications. *)
+   communications.  [SOCK_SEQPACKET] is included for completeness,
+   but is rarely supported by the OS, and needs system calls that
+   are not available in this library. *)
 
 type sockaddr =
     ADDR_UNIX of string
@@ -1366,7 +1367,7 @@ val getaddrinfo:
 
 type name_info =
   { ni_hostname : string;               (** Name or IP address of host *)
-    ni_service : string                 (** Name of service or port number *)
+    ni_service : string;                (** Name of service or port number *)
   }
 (** Host and service information returned by {!Unix.getnameinfo}. *)
 

diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
index fdf29a1c8943f6938777c5801eae6369c1c7a85f..b3f671646ca63cf32189a9062c475b65c6c9a36e 100644 (file)
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -1243,7 +1243,7 @@ val getaddrinfo:
 
 type name_info =
   { ni_hostname : string;               (** Name or IP address of host *)
-    ni_service : string                 (** Name of service or port number *)
+    ni_service : string;                (** Name of service or port number *)
   }
 (** Host and service information returned by {!Unix.getnameinfo}. *)
 

diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c
index 1d261295fb5254326166bcd43adbbf3cfb615c06..fee298f23d20f18201beb1ce1292d11368828b9e 100644 (file)
--- a/otherlibs/unix/wait.c
+++ b/otherlibs/unix/wait.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/alloc.h>
 #include <caml/fail.h>

diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
index 26d9c5a63bb038e5dbd2b5151307e42f3fb154eb..e9917ae907eb8074d972600314711b13c0ea4851 100644 (file)
--- a/otherlibs/win32graph/Makefile.nt
+++ b/otherlibs/win32graph/Makefile.nt
@@ -20,7 +20,7 @@ WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32)
 LINKOPTS=-cclib "\"$(WIN32LIBS)\""
 LDOPTS=-ldopt "$(WIN32LIBS)"
 
-include ../Makefile.nt
+include ../Makefile
 
 graphics.ml: ../graph/graphics.ml
        cp ../graph/graphics.ml graphics.ml

diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c
index 65642838823125ce6ac939aa616373ac04cb836e..aaedcfa7ed80602c6c5159117de4331a12d1ea65 100755 (executable)
--- a/otherlibs/win32graph/events.c
+++ b/otherlibs/win32graph/events.c
@@ -22,7 +22,8 @@ enum {
   EVENT_BUTTON_DOWN = 1,
   EVENT_BUTTON_UP = 2,
   EVENT_KEY_PRESSED = 4,
-  EVENT_MOUSE_MOTION = 8
+  EVENT_MOUSE_MOTION = 8,
+  EVENT_WINDOW_CLOSED = 16
 };
 
 struct event_data {
@@ -105,6 +106,10 @@ void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam)
     last_pos = lParam;
     caml_gr_enqueue_event(EVENT_MOUSE_MOTION, lParam, last_button, 0);
     break;
+  case WM_DESTROY:
+    // Release any calls to Graphics.wait_next_event
+    ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL);
+    break;
   }
 }
 
@@ -157,15 +162,20 @@ static value caml_gr_wait_event_blocking(int mask)
     /* Pop oldest event in queue */
     EnterCriticalSection(&caml_gr_queue_mutex);
     ev = caml_gr_queue[caml_gr_head];
-    /* Queue should never be empty at this point, but just in case... */
+    /* Empty queue means the window was closed */
     if (QueueIsEmpty) {
-      ev.kind = 0;
+      ev.kind = EVENT_WINDOW_CLOSED;
     } else {
       caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE;
     }
     LeaveCriticalSection(&caml_gr_queue_mutex);
     /* Check if it matches */
   } while ((ev.kind & mask) == 0);
+
+  if (ev.kind == EVENT_WINDOW_CLOSED) {
+    gr_fail("graphic screen not opened", NULL);
+  }
+
   return caml_gr_wait_allocate_result(ev.mouse_x, ev.mouse_y, ev.button,
                                       ev.kind == EVENT_KEY_PRESSED,
                                       ev.key);
@@ -176,7 +186,7 @@ CAMLprim value caml_gr_wait_event(value eventlist) /* ML */
   int mask, poll;
 
   gr_check_open();
-  mask = 0;
+  mask = EVENT_WINDOW_CLOSED;
   poll = 0;
   while (eventlist != Val_int(0)) {
     switch (Int_val(Field(eventlist, 0))) {

diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
index 016e52ebbc4fffbb35c724ab76d62d14fed44837..15c029a84358d8efb4ce65f4ce97d1fb94bb6de2 100644 (file)
--- a/otherlibs/win32graph/open.c
+++ b/otherlibs/win32graph/open.c
@@ -104,7 +104,6 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,
                 // End application
         case WM_DESTROY:
                 ResetForClose(hwnd);
-                gr_check_open();
                 break;
         }
         caml_gr_handle_event(msg, wParam, lParam);

diff --git a/otherlibs/win32unix/Makefile b/otherlibs/win32unix/Makefile
deleted file mode 100644 (file)
index 58208a3..0000000
--- a/otherlibs/win32unix/Makefile
+++ /dev/null
@@ -1,18 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-include Makefile.common
-
-include ../Makefile

diff --git a/otherlibs/win32unix/Makefile.common b/otherlibs/win32unix/Makefile.common
deleted file mode 100644 (file)
index 9487db0..0000000
--- a/otherlibs/win32unix/Makefile.common
+++ /dev/null
@@ -1,63 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-# Files in this directory
-WIN_FILES = accept.c bind.c channels.c close.c \
-  close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \
-  getpeername.c getpid.c getsockname.c gettimeofday.c \
-  link.c listen.c lockf.c lseek.c nonblock.c \
-  mkdir.c open.c pipe.c read.c readlink.c rename.c \
-  select.c sendrecv.c \
-  shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
-  symlink.c system.c times.c unixsupport.c windir.c winwait.c write.c \
-  winlist.c winworker.c windbug.c
-
-# Files from the ../unix directory
-UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
-  cstringv.c envir.c execv.c execve.c execvp.c \
-  exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
-  getnameinfo.c getproto.c \
-  getserv.c gmtime.c putenv.c rmdir.c \
-  socketaddr.c strofaddr.c time.c unlink.c utimes.c
-
-UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml
-
-ALL_FILES=$(WIN_FILES) $(UNIX_FILES)
-WSOCKLIB=$(call SYSLIB,ws2_32)
-ADVAPI32LIB=$(call SYSLIB,advapi32)
-
-LIBNAME=unix
-COBJS=$(ALL_FILES:.c=.$(O))
-CAMLOBJS=unix.cmo unixLabels.cmo
-LINKOPTS=-cclib $(WSOCKLIB) -cclib $(ADVAPI32LIB)
-LDOPTS=-ldopt $(WSOCKLIB) -ldopt $(ADVAPI32LIB)
-EXTRACAMLFLAGS=-nolabels
-EXTRACFLAGS=-I../unix
-HEADERS=unixsupport.h socketaddr.h
-
-
-include ../Makefile.nt
-
-clean::
-       rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
-
-$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
-       cp ../unix/$* $*
-
-depend:
-
-$(COBJS): unixsupport.h
-
-include .depend

diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
index bb59270d13b5b4648342f36c697d9cb351345222..ddedd03ea279a5503b84e154665b6eb5bcdabc17 100644 (file)
--- a/otherlibs/win32unix/Makefile.nt
+++ b/otherlibs/win32unix/Makefile.nt
@@ -13,6 +13,51 @@
 #*                                                                        *
 #**************************************************************************
 
-include Makefile.common
+# Files in this directory
+WIN_FILES = accept.c bind.c channels.c close.c \
+  close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \
+  getpeername.c getpid.c getsockname.c gettimeofday.c \
+  link.c listen.c lockf.c lseek.c nonblock.c \
+  mkdir.c open.c pipe.c read.c readlink.c rename.c \
+  select.c sendrecv.c \
+  shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
+  symlink.c system.c times.c unixsupport.c windir.c winwait.c write.c \
+  winlist.c winworker.c windbug.c
 
-include ../Makefile.nt
+# Files from the ../unix directory
+UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
+  cstringv.c envir.c execv.c execve.c execvp.c \
+  exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
+  getnameinfo.c getproto.c \
+  getserv.c gmtime.c putenv.c rmdir.c \
+  socketaddr.c strofaddr.c time.c unlink.c utimes.c
+
+UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml
+
+ALL_FILES=$(WIN_FILES) $(UNIX_FILES)
+WSOCKLIB=$(call SYSLIB,ws2_32)
+ADVAPI32LIB=$(call SYSLIB,advapi32)
+
+LIBNAME=unix
+COBJS=$(ALL_FILES:.c=.$(O))
+CAMLOBJS=unix.cmo unixLabels.cmo
+LINKOPTS=-cclib $(WSOCKLIB) -cclib $(ADVAPI32LIB)
+LDOPTS=-ldopt $(WSOCKLIB) -ldopt $(ADVAPI32LIB)
+EXTRACAMLFLAGS=-nolabels
+EXTRACFLAGS=-I../unix
+HEADERS=unixsupport.h socketaddr.h
+
+
+include ../Makefile
+
+clean::
+       rm -f $(UNIX_FILES) $(UNIX_CAML_FILES)
+
+$(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
+       cp ../unix/$* $*
+
+depend:
+
+$(COBJS): unixsupport.h
+
+include .depend

diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c
index edd838137919d3dc09dbf62bc53a632ba35ec582..1210e6e5ca28eeb3e746eaf2977d5920c04c3560 100644 (file)
--- a/otherlibs/win32unix/channels.c
+++ b/otherlibs/win32unix/channels.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/alloc.h>
 #include <caml/io.h>
@@ -20,6 +22,11 @@
 #include "unixsupport.h"
 #include <fcntl.h>
 
+#if defined(_MSC_VER) && !defined(_INTPTR_T_DEFINED)
+typedef int intptr_t;
+#define _INTPTR_T_DEFINED
+#endif
+
 extern intptr_t _get_osfhandle(int);
 extern int _open_osfhandle(intptr_t, int);
 
@@ -41,6 +48,9 @@ CAMLprim value win_inchannel_of_filedescr(value handle)
   CAMLlocal1(vchan);
   struct channel * chan;
 
+#if defined(_MSC_VER) && _MSC_VER < 1400
+  fflush(stdin);
+#endif
   chan = caml_open_descriptor_in(win_CRT_fd_of_filedescr(handle));
   if (Descr_kind_val(handle) == KIND_SOCKET)
     chan->flags |= CHANNEL_FLAG_FROM_SOCKET;

diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c
index 936cb89e53f93a27e2c2751b20e5abe3080db145..0afd29b683122677773f5f68acf7fe1b0d4e76a3 100644 (file)
--- a/otherlibs/win32unix/gettimeofday.c
+++ b/otherlibs/win32unix/gettimeofday.c
@@ -27,6 +27,14 @@ CAMLprim value unix_gettimeofday(value unit)
   FILETIME ft;
   double tm;
   GetSystemTimeAsFileTime(&ft);
+#if defined(_MSC_VER) && _MSC_VER < 1300
+  /* This compiler can't cast uint64_t to double! Fortunately, this doesn't
+     matter since SYSTEMTIME is only ever 63-bit (maximum value 31-Dec-30827
+     23:59:59.999, and it requires some skill to set the clock past 2099!)
+   */
+  tm = *(int64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */
+#else
   tm = *(uint64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */
+#endif
   return copy_double(tm * 1e-7);  /* tm is in 100ns */
 }

diff --git a/otherlibs/win32unix/readlink.c b/otherlibs/win32unix/readlink.c
index 696d435fec84b8baf4ae2f89b2dceb79645adade..7b20614cb7b44fd799dd2dcdeeb64db0f721cc0c 100644 (file)
--- a/otherlibs/win32unix/readlink.c
+++ b/otherlibs/win32unix/readlink.c
@@ -26,18 +26,22 @@ CAMLprim value unix_readlink(value opath)
   CAMLparam1(opath);
   CAMLlocal1(result);
   HANDLE h;
-  char* path = String_val(opath);
+  char* path;
   DWORD attributes;
+  caml_unix_check_path(opath, "readlink");
+  path = caml_strdup(String_val(opath));
 
   caml_enter_blocking_section();
   attributes = GetFileAttributes(path);
   caml_leave_blocking_section();
 
   if (attributes == INVALID_FILE_ATTRIBUTES) {
+    caml_stat_free(path);
     win32_maperr(GetLastError());
     uerror("readlink", opath);
   }
   else if (!(attributes & FILE_ATTRIBUTE_REPARSE_POINT)) {
+    caml_stat_free(path);
     errno = EINVAL;
     uerror("readlink", opath);
   }
@@ -51,6 +55,7 @@ CAMLprim value unix_readlink(value opath)
                         FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT,
                         NULL)) == INVALID_HANDLE_VALUE) {
       caml_leave_blocking_section();
+      caml_stat_free(path);
       errno = ENOENT;
       uerror("readlink", opath);
     }
@@ -59,6 +64,8 @@ CAMLprim value unix_readlink(value opath)
       DWORD read;
       REPARSE_DATA_BUFFER* point;
 
+      caml_stat_free(path);
+
       if (DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, 16384, &read, NULL)) {
         caml_leave_blocking_section();
         point = (REPARSE_DATA_BUFFER*)buffer;

diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c
index ad77bf96fd8f9559b973c2776f346fff68c1a1f7..f693941d7d1b3a2a1a8f6aef72f1a323b04e2b0d 100644 (file)
--- a/otherlibs/win32unix/select.c
+++ b/otherlibs/win32unix/select.c
@@ -932,14 +932,19 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds,
 #define MAX(a, b) ((a) > (b) ? (a) : (b))
 
 /* Convert fdlist to an fd_set if all the handles in fdlist are
- * sockets and return 0.  Returns 1 if a non-socket value is
- * encountered.
+ * sockets and return 1.  Returns 0 if a non-socket value is
+ * encountered, or if there are more than FD_SETSIZE sockets.
  */
 static int fdlist_to_fdset(value fdlist, fd_set *fdset)
 {
   value l, c;
+  int n = 0;
   FD_ZERO(fdset);
   for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+    if (++n > FD_SETSIZE) {
+      DEBUG_PRINT("More than FD_SETSIZE sockets");
+      return 0;
+    }
     c = Field(l, 0);
     if (Descr_kind_val(c) == KIND_SOCKET) {
       FD_SET(Socket_val(c), fdset);

diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c
index 1b7af930a4a411899566e31be7b1d1ba835ee59d..6389adeafe69dd23728f7f437ce0bc1f2e818fb9 100644 (file)
--- a/otherlibs/win32unix/sleep.c
+++ b/otherlibs/win32unix/sleep.c
@@ -20,8 +20,9 @@
 CAMLprim value unix_sleep(t)
      value t;
 {
+  double d = Double_val(t);
   enter_blocking_section();
-  Sleep(Double_val(t) * 1e3);
+  Sleep(d * 1e3);
   leave_blocking_section();
   return Val_unit;
 }

diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
index 12f5af53f85b514fd995db90134ca30d95379788..dd5fae2204cec87512c8ea23083dd77823cf4529 100644 (file)
--- a/otherlibs/win32unix/stat.c
+++ b/otherlibs/win32unix/stat.c
@@ -35,10 +35,14 @@
 #define S_IFLNK (S_IFDIR | S_IFREG)
 #endif
 #ifndef S_IFIFO
-#define S_IFIFO 0
+#ifdef _S_IFIFO
+#define S_IFIFO _S_IFIFO
+#else
+#define S_IFIFO (S_IFREG | S_IFCHR)
+#endif
 #endif
 #ifndef S_IFSOCK
-#define S_IFSOCK 0
+#define S_IFSOCK (S_IFDIR | S_IFCHR)
 #endif
 #ifndef S_IFBLK
 #define S_IFBLK 0
@@ -138,7 +142,8 @@ static int convert_time(FILETIME* time, __time64_t* result, __time64_t def)
   return 1;
 }
 
-static int do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
+/* path allocated outside the OCaml heap */
+static int safe_do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
 {
   BY_HANDLE_FILE_INFORMATION info;
   int i;
@@ -295,6 +300,16 @@ static int do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE fsta
   return 1;
 }
 
+static int do_stat(int do_lstat, int use_64, char* opath, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
+{
+  char* path;
+  int ret;
+  path = caml_strdup(opath);
+  ret = safe_do_stat(do_lstat, use_64, path, l, fstat, st_ino, res);
+  caml_stat_free(path);
+  return ret;
+}
+
 CAMLprim value unix_stat(value path)
 {
   struct _stat64 buf;
@@ -323,6 +338,8 @@ CAMLprim value unix_lstat(value path)
 {
   struct _stat64 buf;
   __int64 st_ino;
+
+  caml_unix_check_path(path, "lstat");
   if (!do_stat(1, 0, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
     uerror("lstat", path);
   }
@@ -333,30 +350,66 @@ CAMLprim value unix_lstat_64(value path)
 {
   struct _stat64 buf;
   __int64 st_ino;
+
+  caml_unix_check_path(path, "lstat");
   if (!do_stat(1, 1, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
     uerror("lstat", path);
   }
   return stat_aux(1, st_ino, &buf);
 }
 
-CAMLprim value unix_fstat(value handle)
+static value do_fstat(value handle, int use_64)
 {
   int ret;
   struct _stat64 buf;
   __int64 st_ino;
-  if (!do_stat(0, 0, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
+  HANDLE h;
+  DWORD ft;
+
+  st_ino = 0;
+  memset(&buf, 0, sizeof buf);
+  buf.st_nlink = 1;
+
+  h = Handle_val(handle);
+  ft = GetFileType(h) & ~FILE_TYPE_REMOTE;
+  switch(ft) {
+  case FILE_TYPE_DISK:
+    if (!safe_do_stat(0, use_64, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
+      uerror("fstat", Nothing);
+    }
+    break;
+  case FILE_TYPE_CHAR:
+    buf.st_mode = S_IFCHR;
+    break;
+  case FILE_TYPE_PIPE:
+    {
+      DWORD n_avail;
+      if (Descr_kind_val(handle) == KIND_SOCKET) {
+        buf.st_mode = S_IFSOCK;
+      }
+      else {
+        buf.st_mode = S_IFIFO;
+      }
+      if (PeekNamedPipe(h, NULL, 0, NULL, &n_avail, NULL)) {
+        buf.st_size = n_avail;
+      }
+    }
+    break;
+  case FILE_TYPE_UNKNOWN:
+    unix_error(EBADF, "fstat", Nothing);
+  default:
+    win32_maperr(GetLastError());
     uerror("fstat", Nothing);
   }
-  return stat_aux(0, st_ino, &buf);
+  return stat_aux(use_64, st_ino, &buf);
+}
+
+CAMLprim value unix_fstat(value handle)
+{
+  return do_fstat(handle, 0);
 }
 
 CAMLprim value unix_fstat_64(value handle)
 {
-  int ret;
-  struct _stat64 buf;
-  __int64 st_ino;
-  if (!do_stat(0, 1, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
-    uerror("fstat", Nothing);
-  }
-  return stat_aux(1, st_ino, &buf);
+  return do_fstat(handle, 1);
 }

diff --git a/otherlibs/win32unix/symlink.c b/otherlibs/win32unix/symlink.c
index ec1c4a0345e16574b0008e027833572314f7f9e7..36597ab07356db6aad99f933c0851460d286c620 100644 (file)
--- a/otherlibs/win32unix/symlink.c
+++ b/otherlibs/win32unix/symlink.c
@@ -29,11 +29,15 @@ typedef BOOLEAN (WINAPI *LPFN_CREATESYMBOLICLINK) (LPTSTR, LPTSTR, DWORD);
 static LPFN_CREATESYMBOLICLINK pCreateSymbolicLink = NULL;
 static int no_symlink = 0;
 
-CAMLprim value unix_symlink(value to_dir, value source, value dest)
+CAMLprim value unix_symlink(value to_dir, value osource, value odest)
 {
-  CAMLparam3(to_dir, source, dest);
+  CAMLparam3(to_dir, osource, odest);
   DWORD flags = (Bool_val(to_dir) ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0);
   BOOLEAN result;
+  LPTSTR source;
+  LPTSTR dest;
+  caml_unix_check_path(osource, "symlink");
+  caml_unix_check_path(odest, "symlink");
 
 again:
   if (no_symlink) {
@@ -46,13 +50,20 @@ again:
     goto again;
   }
 
+  /* Copy source and dest outside the OCaml heap */
+  source = caml_strdup(String_val(osource));
+  dest = caml_strdup(String_val(odest));
+
   caml_enter_blocking_section();
-  result = pCreateSymbolicLink(String_val(dest), String_val(source), flags);
+  result = pCreateSymbolicLink(dest, source, flags);
   caml_leave_blocking_section();
 
+  caml_stat_free(source);
+  caml_stat_free(dest);
+
   if (!result) {
     win32_maperr(GetLastError());
-    uerror("symlink", dest);
+    uerror("symlink", odest);
   }
 
   CAMLreturn(Val_unit);
@@ -76,7 +87,7 @@ CAMLprim value unix_has_symlink(value unit)
 
       if (!GetTokenInformation(hProcess, TokenPrivileges, NULL, 0, &length)) {
         if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
-          TOKEN_PRIVILEGES* privileges = (TOKEN_PRIVILEGES*)malloc(length);
+          TOKEN_PRIVILEGES* privileges = (TOKEN_PRIVILEGES*)caml_stat_alloc(length);
           if (GetTokenInformation(hProcess,
                                   TokenPrivileges,
                                   privileges,
@@ -91,7 +102,7 @@ CAMLprim value unix_has_symlink(value unit)
             }
           }
 
-          free(privileges);
+          caml_stat_free(privileges);
         }
       }
     }

diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c
index 00f3bae9c9c13a09bef7b26154a0571d2a56f5aa..dc0519dcd6945cc9f33481b24c221a330c51728d 100644 (file)
--- a/otherlibs/win32unix/times.c
+++ b/otherlibs/win32unix/times.c
@@ -20,7 +20,15 @@
 
 
 double to_sec(FILETIME ft) {
+#if defined(_MSC_VER) && _MSC_VER < 1300
+  /* See gettimeofday.c - it is not possible for these values to be 64-bit, so
+     there's no worry about using a signed struct in order to work around the
+     lack of support for casting int64_t to double.
+   */
+  LARGE_INTEGER tmp;
+#else
   ULARGE_INTEGER tmp;
+#endif
 
   tmp.u.LowPart = ft.dwLowDateTime;
   tmp.u.HighPart = ft.dwHighDateTime;

diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index d24bb67944f927b82df4aff56a092b4887e094a3..eea61ebb9c5a2b507a5a0fc59d88500ed638b545 100644 (file)
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -147,7 +147,7 @@ external getpid : unit -> int = "unix_getpid"
 let fork () = invalid_arg "Unix.fork not implemented"
 let wait () = invalid_arg "Unix.wait not implemented"
 let getppid () = invalid_arg "Unix.getppid not implemented"
-let nice prio = invalid_arg "Unix.nice not implemented"
+let nice _ = invalid_arg "Unix.nice not implemented"
 
 (* Basic file input/output *)
 
@@ -224,8 +224,8 @@ type seek_command =
 
 external lseek : file_descr -> int -> seek_command -> int = "unix_lseek"
 
-let truncate name len = invalid_arg "Unix.truncate not implemented"
-let ftruncate fd len = invalid_arg "Unix.ftruncate not implemented"
+let truncate _name _len = invalid_arg "Unix.truncate not implemented"
+let ftruncate _fd _len = invalid_arg "Unix.ftruncate not implemented"
 
 (* File statistics *)
 
@@ -270,9 +270,9 @@ module LargeFile =
   struct
     external lseek : file_descr -> int64 -> seek_command -> int64
        = "unix_lseek_64"
-    let truncate name len =
+    let truncate _name _len =
       invalid_arg "Unix.LargeFile.truncate not implemented"
-    let ftruncate name len =
+    let ftruncate _name _len =
       invalid_arg "Unix.LargeFile.ftruncate not implemented"
     type stats =
       { st_dev : int;
@@ -302,10 +302,10 @@ type access_permission =
   | F_OK
 
 external chmod : string -> file_perm -> unit = "unix_chmod"
-let fchmod fd perm = invalid_arg "Unix.fchmod not implemented"
-let chown file perm = invalid_arg "Unix.chown not implemented"
-let fchown fd perm = invalid_arg "Unix.fchown not implemented"
-let umask msk = invalid_arg "Unix.umask not implemented"
+let fchmod _fd _perm = invalid_arg "Unix.fchmod not implemented"
+let chown _file _perm = invalid_arg "Unix.chown not implemented"
+let fchown _fd _perm = invalid_arg "Unix.fchown not implemented"
+let umask _msk = invalid_arg "Unix.umask not implemented"
 
 external access : string -> access_permission list -> unit = "unix_access"
 
@@ -371,7 +371,7 @@ let rewinddir d =
 
 external pipe : unit -> file_descr * file_descr = "unix_pipe"
 
-let mkfifo name perm = invalid_arg "Unix.mkfifo not implemented"
+let mkfifo _name _perm = invalid_arg "Unix.mkfifo not implemented"
 
 (* Symbolic links *)
 
@@ -416,9 +416,9 @@ let kill pid signo =
         (* could be more precise *)
 
 type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK
-let sigprocmask cmd sigs = invalid_arg "Unix.sigprocmask not implemented"
+let sigprocmask _cmd _sigs = invalid_arg "Unix.sigprocmask not implemented"
 let sigpending () = invalid_arg "Unix.sigpending not implemented"
-let sigsuspend sigs = invalid_arg "Unix.sigsuspend not implemented"
+let sigsuspend _sigs = invalid_arg "Unix.sigsuspend not implemented"
 let pause () = invalid_arg "Unix.pause not implemented"
 
 (* Time functions *)
@@ -445,7 +445,7 @@ external gettimeofday : unit -> float = "unix_gettimeofday"
 external gmtime : float -> tm = "unix_gmtime"
 external localtime : float -> tm = "unix_localtime"
 external mktime : tm -> float * tm = "unix_mktime"
-let alarm n = invalid_arg "Unix.alarm not implemented"
+let alarm _n = invalid_arg "Unix.alarm not implemented"
 external sleepf : float -> unit = "unix_sleep"
 let sleep n = sleepf (float n)
 external times: unit -> process_times = "unix_times"
@@ -460,18 +460,18 @@ type interval_timer_status =
   { it_interval: float;
     it_value: float }
 
-let getitimer it = invalid_arg "Unix.getitimer not implemented"
-let setitimer it tm = invalid_arg "Unix.setitimer not implemented"
+let getitimer _it = invalid_arg "Unix.getitimer not implemented"
+let setitimer _it _tm = invalid_arg "Unix.setitimer not implemented"
 
 (* User id, group id *)
 
 let getuid () = 1
 let geteuid = getuid
-let setuid id = invalid_arg "Unix.setuid not implemented"
+let setuid _id = invalid_arg "Unix.setuid not implemented"
 
 let getgid () = 1
 let getegid = getgid
-let setgid id = invalid_arg "Unix.setgid not implemented"
+let setgid _id = invalid_arg "Unix.setgid not implemented"
 
 let getgroups () = [|1|]
 let setgroups _ = invalid_arg "Unix.setgroups not implemented"
@@ -493,7 +493,7 @@ type group_entry =
     gr_mem : string array }
 
 let getlogin () = try Sys.getenv "USERNAME" with Not_found -> ""
-let getpwnam x = raise Not_found
+let getpwnam _x = raise Not_found
 let getgrnam = getpwnam
 let getpwuid = getpwnam
 let getgrgid = getpwnam
@@ -549,7 +549,7 @@ type msg_flag =
 
 external socket : socket_domain -> socket_type -> int -> file_descr
                                   = "unix_socket"
-let socketpair dom ty proto = invalid_arg "Unix.socketpair not implemented"
+let socketpair _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
 external accept : file_descr -> file_descr * sockaddr = "unix_accept"
 external bind : file_descr -> sockaddr -> unit = "unix_bind"
 external connect : file_descr -> sockaddr -> unit = "unix_connect"
@@ -958,7 +958,7 @@ let open_connection sockaddr =
 let shutdown_connection inchan =
   shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
 
-let establish_server server_fun sockaddr =
+let establish_server _server_fun _sockaddr =
   invalid_arg "Unix.establish_server not implemented"
 
 (* Terminal interface *)
@@ -1006,13 +1006,13 @@ type terminal_io = {
 
 type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH
 
-let tcgetattr fd = invalid_arg "Unix.tcgetattr not implemented"
-let tcsetattr fd wh = invalid_arg "Unix.tcsetattr not implemented"
-let tcsendbreak fd n = invalid_arg "Unix.tcsendbreak not implemented"
-let tcdrain fd = invalid_arg "Unix.tcdrain not implemented"
+let tcgetattr _fd = invalid_arg "Unix.tcgetattr not implemented"
+let tcsetattr _fd _wh = invalid_arg "Unix.tcsetattr not implemented"
+let tcsendbreak _fd _n = invalid_arg "Unix.tcsendbreak not implemented"
+let tcdrain _fd = invalid_arg "Unix.tcdrain not implemented"
 
 type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH
-let tcflush fd q = invalid_arg "Unix.tcflush not implemented"
+let tcflush _fd _q = invalid_arg "Unix.tcflush not implemented"
 type flow_action = TCOOFF | TCOON | TCIOFF | TCION
-let tcflow fd fl = invalid_arg "Unix.tcflow not implemented"
+let tcflow _fd _fl = invalid_arg "Unix.tcflow not implemented"
 let setsid () = invalid_arg "Unix.setsid not implemented"

diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h
index 8427ebfc3b77d3e551421321d238ad6a97f7bfc0..cc5ee690f17bb9e8e9cba16584fc9369739cf516 100644 (file)
--- a/otherlibs/win32unix/windbug.h
+++ b/otherlibs/win32unix/windbug.h
@@ -37,6 +37,34 @@
 /* Test if we are in dbug mode */
 int  debug_test    (void);
 
+#elif defined(_MSC_VER) && _MSC_VER < 1300
+
+#define DEBUG_PRINT(fmt)
+
+/* __pragma wasn't added until Visual C++ .NET 2002, so simply disable the
+   warning entirely
+ */
+
+#pragma warning (disable:4002)
+
+#elif defined(_MSC_VER) && _MSC_VER <= 1400
+
+/* Not all versions of the Visual Studio 2005 C Compiler (Version 14) support
+   variadic macros, hence the test for this branch being <= 1400 rather than
+   < 1400.
+   This convoluted pair of macros allow DEBUG_PRINT to remain while temporarily
+   suppressing the warning displayed for a macro called with too many
+   parameters.
+ */
+#define DEBUG_PRINT_S(fmt) __pragma(warning(pop))
+#define DEBUG_PRINT \
+  __pragma(warning(push)) \
+  __pragma(warning(disable:4002)) \
+  DEBUG_PRINT_S
+
 #else
+
+/* Visual Studio supports variadic macros in all versions from 2008 (CL 15). */
 #define DEBUG_PRINT(fmt, ...)
+
 #endif

diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index e3bf483df3f1c8261e0a87a405be4b19f5fea2f0..82db57bd3a8a5ce70527f3f05e079c515d5dc0a5 100644 (file)
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -87,6 +87,7 @@ module Pat = struct
   let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a)
   let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a)
   let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a)
+  let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b))
   let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a)
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a)
 end
@@ -122,6 +123,7 @@ module Exp = struct
   let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
   let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
   let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
+  let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
   let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
   let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
   let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))
@@ -186,9 +188,10 @@ module Sig = struct
   let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
   let attribute ?loc a = mk ?loc (Psig_attribute a)
   let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
     List.map
       (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
-      txt
+      f_txt
 end
 
 module Str = struct
@@ -210,9 +213,10 @@ module Str = struct
   let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
   let attribute ?loc a = mk ?loc (Pstr_attribute a)
   let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
     List.map
       (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
-      txt
+      f_txt
 end
 
 module Cl = struct
@@ -264,9 +268,10 @@ module Ctf = struct
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a)
   let attribute ?loc a = mk ?loc (Pctf_attribute a)
   let text txt =
-    List.map
+   let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
+     List.map
       (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
-      txt
+      f_txt
 
   let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]}
 
@@ -289,9 +294,10 @@ module Cf = struct
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a)
   let attribute ?loc a = mk ?loc (Pcf_attribute a)
   let text txt =
+    let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in
     List.map
       (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds))
-      txt
+      f_txt
 
   let virtual_ ct = Cfk_virtual ct
   let concrete o e = Cfk_concrete (o, e)

diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 6a527feb6eaaa2abe76fb7cfed74b4686b8b9b9d..dc5d0dcc004ce115e923a208bca35dbeba093b95 100644 (file)
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -97,6 +97,7 @@ module Pat:
     val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern
     val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
     val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern
+    val open_: ?loc:loc -> ?attrs:attrs  -> lid -> pattern -> pattern
     val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern
   end
@@ -149,6 +150,9 @@ module Exp:
                   -> expression
     val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression
                    -> expression
+    val letexception:
+      ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
+      -> expression
     val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
     val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
     val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option
@@ -306,21 +310,20 @@ module Mb:
       str -> module_expr -> module_binding
   end
 
-(* Opens *)
+(** Opens *)
 module Opn:
   sig
     val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs ->
       ?override:override_flag -> lid -> open_description
   end
 
-(* Includes *)
+(** Includes *)
 module Incl:
   sig
     val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos
   end
 
 (** Value bindings *)
-
 module Vb:
   sig
     val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text ->

diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index 2f8798a53f4e3ff9e1368930042c589827a47e2e..8518438d829c077195eb48182a070ad4a6c24483 100755 (executable)
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -98,13 +98,13 @@ module T = struct
     | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
     | Ptyp_constr (lid, tl) ->
         iter_loc sub lid; List.iter (sub.typ sub) tl
-    | Ptyp_object (l, o) ->
+    | Ptyp_object (l, _o) ->
         let f (_, a, t) = sub.attributes sub a; sub.typ sub t in
         List.iter f l
     | Ptyp_class (lid, tl) ->
         iter_loc sub lid; List.iter (sub.typ sub) tl
     | Ptyp_alias (t, _) -> sub.typ sub t
-    | Ptyp_variant (rl, b, ll) ->
+    | Ptyp_variant (rl, _b, _ll) ->
         List.iter (row_field sub) rl
     | Ptyp_poly (_, t) -> sub.typ sub t
     | Ptyp_package (lid, l) ->
@@ -115,7 +115,7 @@ module T = struct
   let iter_type_declaration sub
       {ptype_name; ptype_params; ptype_cstrs;
        ptype_kind;
-       ptype_private;
+       ptype_private = _;
        ptype_manifest;
        ptype_attributes;
        ptype_loc} =
@@ -144,7 +144,7 @@ module T = struct
   let iter_type_extension sub
       {ptyext_path; ptyext_params;
        ptyext_constructors;
-       ptyext_private;
+       ptyext_private = _;
        ptyext_attributes} =
     iter_loc sub ptyext_path;
     List.iter (sub.extension_constructor sub) ptyext_constructors;
@@ -189,8 +189,8 @@ module CT = struct
     sub.attributes sub attrs;
     match desc with
     | Pctf_inherit ct -> sub.class_type sub ct
-    | Pctf_val (s, m, v, t) -> sub.typ sub t
-    | Pctf_method (s, p, v, t) -> sub.typ sub t
+    | Pctf_val (_s, _m, _v, t) -> sub.typ sub t
+    | Pctf_method (_s, _p, _v, t) -> sub.typ sub t
     | Pctf_constraint (t1, t2) ->
         sub.typ sub t1; sub.typ sub t2
     | Pctf_attribute x -> sub.attribute sub x
@@ -234,7 +234,7 @@ module MT = struct
     sub.location sub loc;
     match desc with
     | Psig_value vd -> sub.value_description sub vd
-    | Psig_type (rf, l) -> List.iter (sub.type_declaration sub) l
+    | Psig_type (_rf, l) -> List.iter (sub.type_declaration sub) l
     | Psig_typext te -> sub.type_extension sub te
     | Psig_exception ed -> sub.extension_constructor sub ed
     | Psig_module x -> sub.module_declaration sub x
@@ -277,9 +277,9 @@ module M = struct
     match desc with
     | Pstr_eval (x, attrs) ->
         sub.expr sub x; sub.attributes sub attrs
-    | Pstr_value (r, vbs) -> List.iter (sub.value_binding sub) vbs
+    | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs
     | Pstr_primitive vd -> sub.value_description sub vd
-    | Pstr_type (rf, l) -> List.iter (sub.type_declaration sub) l
+    | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l
     | Pstr_typext te -> sub.type_extension sub te
     | Pstr_exception ed -> sub.extension_constructor sub ed
     | Pstr_module x -> sub.module_binding sub x
@@ -303,11 +303,11 @@ module E = struct
     sub.attributes sub attrs;
     match desc with
     | Pexp_ident x -> iter_loc sub x
-    | Pexp_constant x -> ()
-    | Pexp_let (r, vbs, e) ->
+    | Pexp_constant _ -> ()
+    | Pexp_let (_r, vbs, e) ->
         List.iter (sub.value_binding sub) vbs;
         sub.expr sub e
-    | Pexp_fun (lab, def, p, e) ->
+    | Pexp_fun (_lab, def, p, e) ->
         iter_opt (sub.expr sub) def;
         sub.pat sub p;
         sub.expr sub e
@@ -320,7 +320,7 @@ module E = struct
     | Pexp_tuple el -> List.iter (sub.expr sub) el
     | Pexp_construct (lid, arg) ->
         iter_loc sub lid; iter_opt (sub.expr sub) arg
-    | Pexp_variant (lab, eo) ->
+    | Pexp_variant (_lab, eo) ->
         iter_opt (sub.expr sub) eo
     | Pexp_record (l, eo) ->
         List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l;
@@ -338,7 +338,7 @@ module E = struct
         sub.expr sub e1; sub.expr sub e2
     | Pexp_while (e1, e2) ->
         sub.expr sub e1; sub.expr sub e2
-    | Pexp_for (p, e1, e2, d, e3) ->
+    | Pexp_for (p, e1, e2, _d, e3) ->
         sub.pat sub p; sub.expr sub e1; sub.expr sub e2;
         sub.expr sub e3
     | Pexp_coerce (e, t1, t2) ->
@@ -346,7 +346,7 @@ module E = struct
         sub.typ sub t2
     | Pexp_constraint (e, t) ->
         sub.expr sub e; sub.typ sub t
-    | Pexp_send (e, s) -> sub.expr sub e
+    | Pexp_send (e, _s) -> sub.expr sub e
     | Pexp_new lid -> iter_loc sub lid
     | Pexp_setinstvar (s, e) ->
         iter_loc sub s; sub.expr sub e
@@ -355,14 +355,17 @@ module E = struct
     | Pexp_letmodule (s, me, e) ->
         iter_loc sub s; sub.module_expr sub me;
         sub.expr sub e
+    | Pexp_letexception (cd, e) ->
+        sub.extension_constructor sub cd;
+        sub.expr sub e
     | Pexp_assert e -> sub.expr sub e
     | Pexp_lazy e -> sub.expr sub e
     | Pexp_poly (e, t) ->
         sub.expr sub e; iter_opt (sub.typ sub) t
     | Pexp_object cls -> sub.class_structure sub cls
-    | Pexp_newtype (s, e) -> sub.expr sub e
+    | Pexp_newtype (_s, e) -> sub.expr sub e
     | Pexp_pack me -> sub.module_expr sub me
-    | Pexp_open (ovf, lid, e) ->
+    | Pexp_open (_ovf, lid, e) ->
         iter_loc sub lid; sub.expr sub e
     | Pexp_extension x -> sub.extension sub x
     | Pexp_unreachable -> ()
@@ -378,13 +381,13 @@ module P = struct
     | Ppat_any -> ()
     | Ppat_var s -> iter_loc sub s
     | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s
-    | Ppat_constant c -> ()
-    | Ppat_interval (c1, c2) -> ()
+    | Ppat_constant _ -> ()
+    | Ppat_interval _ -> ()
     | Ppat_tuple pl -> List.iter (sub.pat sub) pl
     | Ppat_construct (l, p) ->
         iter_loc sub l; iter_opt (sub.pat sub) p
-    | Ppat_variant (l, p) -> iter_opt (sub.pat sub) p
-    | Ppat_record (lpl, cf) ->
+    | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
+    | Ppat_record (lpl, _cf) ->
         List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl
     | Ppat_array pl -> List.iter (sub.pat sub) pl
     | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2
@@ -395,6 +398,9 @@ module P = struct
     | Ppat_unpack s -> iter_loc sub s
     | Ppat_exception p -> sub.pat sub p
     | Ppat_extension x -> sub.extension sub x
+    | Ppat_open (lid, p) ->
+        iter_loc sub lid; sub.pat sub p
+
 end
 
 module CE = struct
@@ -408,14 +414,14 @@ module CE = struct
         iter_loc sub lid; List.iter (sub.typ sub) tys
     | Pcl_structure s ->
         sub.class_structure sub s
-    | Pcl_fun (lab, e, p, ce) ->
+    | Pcl_fun (_lab, e, p, ce) ->
         iter_opt (sub.expr sub) e;
         sub.pat sub p;
         sub.class_expr sub ce
     | Pcl_apply (ce, l) ->
         sub.class_expr sub ce;
         List.iter (iter_snd (sub.expr sub)) l
-    | Pcl_let (r, vbs, ce) ->
+    | Pcl_let (_r, vbs, ce) ->
         List.iter (sub.value_binding sub) vbs;
         sub.class_expr sub ce
     | Pcl_constraint (ce, ct) ->
@@ -423,16 +429,16 @@ module CE = struct
     | Pcl_extension x -> sub.extension sub x
 
   let iter_kind sub = function
-    | Cfk_concrete (o, e) -> sub.expr sub e
+    | Cfk_concrete (_o, e) -> sub.expr sub e
     | Cfk_virtual t -> sub.typ sub t
 
   let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} =
     sub.location sub loc;
     sub.attributes sub attrs;
     match desc with
-    | Pcf_inherit (o, ce, s) -> sub.class_expr sub ce
-    | Pcf_val (s, m, k) -> iter_loc sub s; iter_kind sub k
-    | Pcf_method (s, p, k) ->
+    | Pcf_inherit (_o, ce, _s) -> sub.class_expr sub ce
+    | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k
+    | Pcf_method (s, _p, k) ->
         iter_loc sub s; iter_kind sub k
     | Pcf_constraint (t1, t2) ->
         sub.typ sub t1; sub.typ sub t2
@@ -444,7 +450,7 @@ module CE = struct
     sub.pat sub pcstr_self;
     List.iter (sub.class_field sub) pcstr_fields
 
-  let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr;
+  let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr;
                          pci_loc; pci_attributes} =
     List.iter (iter_fst (sub.typ sub)) pl;
     iter_loc sub pci_name;
@@ -484,7 +490,7 @@ let default_iterator =
     type_extension = T.iter_type_extension;
     extension_constructor = T.iter_extension_constructor;
     value_description =
-      (fun this {pval_name; pval_type; pval_prim; pval_loc;
+      (fun this {pval_name; pval_type; pval_prim = _; pval_loc;
                  pval_attributes} ->
         iter_loc this pval_name;
         this.typ this pval_type;
@@ -520,7 +526,7 @@ let default_iterator =
 
 
     open_description =
-      (fun this {popen_lid; popen_override; popen_attributes; popen_loc} ->
+      (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} ->
          iter_loc this popen_lid;
          this.location this popen_loc;
          this.attributes this popen_attributes
@@ -561,7 +567,7 @@ let default_iterator =
       );
 
     label_declaration =
-      (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} ->
+      (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}->
          iter_loc this pld_name;
          this.typ this pld_type;
          this.location this pld_loc;
@@ -576,7 +582,7 @@ let default_iterator =
          this.expr this pc_rhs
       );
 
-    location = (fun this l -> ());
+    location = (fun _this _l -> ());
 
     extension = (fun this (s, e) -> iter_loc this s; this.payload this e);
     attribute = (fun this (s, e) -> iter_loc this s; this.payload this e);

diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 8b72b49622a210fe61ae7e7199ef9a6427c42a79..ec409be961fb5940a4ee17bf57bdc313765f7fe1 100644 (file)
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -370,6 +370,10 @@ module E = struct
     | Pexp_letmodule (s, me, e) ->
         letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
           (sub.expr sub e)
+    | Pexp_letexception (cd, e) ->
+        letexception ~loc ~attrs
+          (sub.extension_constructor sub cd)
+          (sub.expr sub e)
     | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
     | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
     | Pexp_poly (e, t) ->
@@ -410,6 +414,7 @@ module P = struct
     | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
     | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p)
     | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
+    | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p)
     | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p)
     | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x)
 end
@@ -613,7 +618,7 @@ let default_mapper =
 
 
 
-    location = (fun this l -> l);
+    location = (fun _this l -> l);
 
     extension = (fun this (s, e) -> (map_loc this s, this.payload this e));
     attribute = (fun this (s, e) -> (map_loc this s, this.payload this e));

diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index 5188b69c7c102de8ad4be7d17491877f02a32256..8cab1c6b8566790feb08b2a6ee79d4ce96fcaf68 100644 (file)
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Auxiliary a.s.t. types used by parsetree and typedtree. *)
+(** Auxiliary AST types used by parsetree and typedtree. *)
 
 type constant =
     Const_int of int

diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml
index 9e452ce1214764f65b986964ef5f785f6d571d1e..bdbefcdf5ef8d0947d537f4d814bae2e9908479a 100755 (executable)
--- a/parsing/builtin_attributes.ml
+++ b/parsing/builtin_attributes.ml
@@ -32,7 +32,7 @@ let rec error_of_extension ext =
       match inner with
       | {pstr_desc=Pstr_extension (ext, _)} :: rest ->
           error_of_extension ext :: sub_from rest
-      | {pstr_loc} :: rest ->
+      | _ :: rest ->
           (Location.errorf ~loc
              "Invalid syntax for sub-error of extension '%s'." txt) ::
             sub_from rest
@@ -188,3 +188,26 @@ let explicit_arity =
       | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true
       | _ -> false
     )
+
+let immediate =
+  List.exists
+    (function
+      | ({txt="ocaml.immediate"|"immediate"; _}, _) -> true
+      | _ -> false
+    )
+
+(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
+   attributes cannot be input by the user, they are added by the
+   compiler when applying the default setting. This is done to record
+   in the .cmi the default used by the compiler when compiling the
+   source file because the default can change between compiler
+   invocations. *)
+
+let check l (x, _) = List.mem x.txt l
+
+let has_unboxed attr =
+  List.exists (check ["ocaml.unboxed"; "unboxed"])
+    attr
+
+let has_boxed attr =
+  List.exists (check ["ocaml.boxed"; "boxed"]) attr

diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli
index 60b709a85a003c21f6b1c73e438f48498b400c56..9add63733f995de2d459a29e78ea07a09927ec1e 100755 (executable)
--- a/parsing/builtin_attributes.mli
+++ b/parsing/builtin_attributes.mli
@@ -23,6 +23,8 @@
    ocaml.explicit_arity (for camlp4/camlp5)
    ocaml.warn_on_literal_pattern
    ocaml.deprecated_mutable
+   ocaml.immediate
+   ocaml.boxed / ocaml.unboxed
 *)
 
 
@@ -45,3 +47,9 @@ val emit_external_warnings: Ast_iterator.iterator
 
 val warn_on_literal_pattern: Parsetree.attributes -> bool
 val explicit_arity: Parsetree.attributes -> bool
+
+
+val immediate: Parsetree.attributes -> bool
+
+val has_unboxed: Parsetree.attributes -> bool
+val has_boxed: Parsetree.attributes -> bool

diff --git a/parsing/depend.ml b/parsing/depend.ml
new file mode 100644 (file)
index 0000000..8703ffe
--- /dev/null
+++ b/parsing/depend.ml
@@ -0,0 +1,517 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Asttypes
+open Location
+open Longident
+open Parsetree
+
+module StringSet = Set.Make(struct type t = string let compare = compare end)
+module StringMap = Map.Make(String)
+
+(* Module resolution map *)
+(* Node (set of imports for this path, map for submodules) *)
+type map_tree = Node of StringSet.t * bound_map
+and  bound_map = map_tree StringMap.t
+let bound = Node (StringSet.empty, StringMap.empty)
+
+(*let get_free (Node (s, _m)) = s*)
+let get_map (Node (_s, m)) = m
+let make_leaf s = Node (StringSet.singleton s, StringMap.empty)
+let make_node m =  Node (StringSet.empty, m)
+let rec weaken_map s (Node(s0,m0)) =
+  Node (StringSet.union s s0, StringMap.map (weaken_map s) m0)
+let rec collect_free (Node (s, m)) =
+  StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s
+
+(* Returns the imports required to access the structure at path p *)
+(* Only raises Not_found if the head of p is not in the toplevel map *)
+let rec lookup_free p m =
+  match p with
+    [] -> raise Not_found
+  | s::p ->
+      let Node (f, m') = StringMap.find s m  in
+      try lookup_free p m' with Not_found -> f
+
+(* Returns the node corresponding to the structure at path p *)
+let rec lookup_map lid m =
+  match lid with
+    Lident s    -> StringMap.find s m
+  | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m))
+  | Lapply _    -> raise Not_found
+
+(* Collect free module identifiers in the a.s.t. *)
+
+let free_structure_names = ref StringSet.empty
+
+let add_names s =
+  free_structure_names := StringSet.union s !free_structure_names
+
+let rec add_path bv ?(p=[]) = function
+  | Lident s ->
+      let free =
+        try lookup_free (s::p) bv with Not_found -> StringSet.singleton s
+      in
+      (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free;
+        prerr_endline "";*)
+      add_names free
+  | Ldot(l, s) -> add_path bv ~p:(s::p) l
+  | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
+
+let open_module bv lid =
+  match lookup_map lid bv with
+  | Node (s, m) ->
+      add_names s;
+      StringMap.fold StringMap.add m bv
+  | exception Not_found ->
+      add_path bv lid; bv
+
+let add_parent bv lid =
+  match lid.txt with
+    Ldot(l, _s) -> add_path bv l
+  | _ -> ()
+
+let add = add_parent
+
+let addmodule bv lid = add_path bv lid.txt
+
+let handle_extension ext =
+  match (fst ext).txt with
+  | "error" | "ocaml.error" ->
+    raise (Location.Error
+             (Builtin_attributes.error_of_extension ext))
+  | _ ->
+    ()
+
+let rec add_type bv ty =
+  match ty.ptyp_desc with
+    Ptyp_any -> ()
+  | Ptyp_var _ -> ()
+  | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
+  | Ptyp_tuple tl -> List.iter (add_type bv) tl
+  | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
+  | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl
+  | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
+  | Ptyp_alias(t, _) -> add_type bv t
+  | Ptyp_variant(fl, _, _) ->
+      List.iter
+        (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
+          | Rinherit sty -> add_type bv sty)
+        fl
+  | Ptyp_poly(_, t) -> add_type bv t
+  | Ptyp_package pt -> add_package_type bv pt
+  | Ptyp_extension e -> handle_extension e
+
+and add_package_type bv (lid, l) =
+  add bv lid;
+  List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
+
+let add_opt add_fn bv = function
+    None -> ()
+  | Some x -> add_fn bv x
+
+let add_constructor_arguments bv = function
+  | Pcstr_tuple l -> List.iter (add_type bv) l
+  | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
+
+let add_constructor_decl bv pcd =
+  add_constructor_arguments bv pcd.pcd_args;
+  Misc.may (add_type bv) pcd.pcd_res
+
+let add_type_declaration bv td =
+  List.iter
+    (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
+    td.ptype_cstrs;
+  add_opt add_type bv td.ptype_manifest;
+  let add_tkind = function
+    Ptype_abstract -> ()
+  | Ptype_variant cstrs ->
+      List.iter (add_constructor_decl bv) cstrs
+  | Ptype_record lbls ->
+      List.iter (fun pld -> add_type bv pld.pld_type) lbls
+  | Ptype_open -> () in
+  add_tkind td.ptype_kind
+
+let add_extension_constructor bv ext =
+  match ext.pext_kind with
+    Pext_decl(args, rty) ->
+      add_constructor_arguments bv args;
+      Misc.may (add_type bv) rty
+  | Pext_rebind lid -> add bv lid
+
+let add_type_extension bv te =
+  add bv te.ptyext_path;
+  List.iter (add_extension_constructor bv) te.ptyext_constructors
+
+let rec add_class_type bv cty =
+  match cty.pcty_desc with
+    Pcty_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
+      add_type bv ty;
+      List.iter (add_class_type_field bv) fieldl
+  | Pcty_arrow(_, ty1, cty2) ->
+      add_type bv ty1; add_class_type bv cty2
+  | Pcty_extension e -> handle_extension e
+
+and add_class_type_field bv pctf =
+  match pctf.pctf_desc with
+    Pctf_inherit cty -> add_class_type bv cty
+  | Pctf_val(_, _, _, ty) -> add_type bv ty
+  | Pctf_method(_, _, _, ty) -> add_type bv ty
+  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pctf_attribute _ -> ()
+  | Pctf_extension e -> handle_extension e
+
+let add_class_description bv infos =
+  add_class_type bv infos.pci_expr
+
+let add_class_type_declaration = add_class_description
+
+let pattern_bv = ref StringMap.empty
+
+let rec add_pattern bv pat =
+  match pat.ppat_desc with
+    Ppat_any -> ()
+  | Ppat_var _ -> ()
+  | Ppat_alias(p, _) -> add_pattern bv p
+  | Ppat_interval _
+  | Ppat_constant _ -> ()
+  | Ppat_tuple pl -> List.iter (add_pattern bv) pl
+  | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op
+  | Ppat_record(pl, _) ->
+      List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
+  | Ppat_array pl -> List.iter (add_pattern bv) pl
+  | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
+  | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
+  | Ppat_variant(_, op) -> add_opt add_pattern bv op
+  | Ppat_type li -> add bv li
+  | Ppat_lazy p -> add_pattern bv p
+  | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv
+  | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p
+  | Ppat_exception p -> add_pattern bv p
+  | Ppat_extension e -> handle_extension e
+
+let add_pattern bv pat =
+  pattern_bv := bv;
+  add_pattern bv pat;
+  !pattern_bv
+
+let rec add_expr bv exp =
+  match exp.pexp_desc with
+    Pexp_ident l -> add bv l
+  | Pexp_constant _ -> ()
+  | Pexp_let(rf, pel, e) ->
+      let bv = add_bindings rf bv pel in add_expr bv e
+  | Pexp_fun (_, opte, p, e) ->
+      add_opt add_expr bv opte; add_expr (add_pattern bv p) e
+  | Pexp_function pel ->
+      add_cases bv pel
+  | Pexp_apply(e, el) ->
+      add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
+  | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
+  | Pexp_tuple el -> List.iter (add_expr bv) el
+  | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte
+  | Pexp_variant(_, opte) -> add_opt add_expr bv opte
+  | Pexp_record(lblel, opte) ->
+      List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
+      add_opt add_expr bv opte
+  | Pexp_field(e, fld) -> add_expr bv e; add bv fld
+  | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
+  | Pexp_array el -> List.iter (add_expr bv) el
+  | Pexp_ifthenelse(e1, e2, opte3) ->
+      add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
+  | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
+  | Pexp_for( _, e1, e2, _, e3) ->
+      add_expr bv e1; add_expr bv e2; add_expr bv e3
+  | Pexp_coerce(e1, oty2, ty3) ->
+      add_expr bv e1;
+      add_opt add_type bv oty2;
+      add_type bv ty3
+  | Pexp_constraint(e1, ty2) ->
+      add_expr bv e1;
+      add_type bv ty2
+  | Pexp_send(e, _m) -> add_expr bv e
+  | Pexp_new li -> add bv li
+  | Pexp_setinstvar(_v, e) -> add_expr bv e
+  | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
+  | Pexp_letmodule(id, m, e) ->
+      let b = add_module_binding bv m in
+      add_expr (StringMap.add id.txt b bv) e
+  | Pexp_letexception(_, e) -> add_expr bv e
+  | Pexp_assert (e) -> add_expr bv e
+  | Pexp_lazy (e) -> add_expr bv e
+  | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
+  | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
+      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
+  | Pexp_newtype (_, e) -> add_expr bv e
+  | Pexp_pack m -> add_module bv m
+  | Pexp_open (_ovf, m, e) ->
+      let bv = open_module bv m.txt in add_expr bv e
+  | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
+                              "extension_constructor"); _ },
+                     PStr [item]) as e) ->
+      begin match item.pstr_desc with
+      | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
+      | _ -> handle_extension e
+      end
+  | Pexp_extension e -> handle_extension e
+  | Pexp_unreachable -> ()
+
+and add_cases bv cases =
+  List.iter (add_case bv) cases
+
+and add_case bv {pc_lhs; pc_guard; pc_rhs} =
+  let bv = add_pattern bv pc_lhs in
+  add_opt add_expr bv pc_guard;
+  add_expr bv pc_rhs
+
+and add_bindings recf bv pel =
+  let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
+  let bv = if recf = Recursive then bv' else bv in
+  List.iter (fun x -> add_expr bv x.pvb_expr) pel;
+  bv'
+
+and add_modtype bv mty =
+  match mty.pmty_desc with
+    Pmty_ident l -> add bv l
+  | Pmty_alias l -> addmodule bv l
+  | Pmty_signature s -> add_signature bv s
+  | Pmty_functor(id, mty1, mty2) ->
+      Misc.may (add_modtype bv) mty1;
+      add_modtype (StringMap.add id.txt bound bv) mty2
+  | Pmty_with(mty, cstrl) ->
+      add_modtype bv mty;
+      List.iter
+        (function
+          | Pwith_type (_, td) -> add_type_declaration bv td
+          | Pwith_module (_, lid) -> addmodule bv lid
+          | Pwith_typesubst td -> add_type_declaration bv td
+          | Pwith_modsubst (_, lid) -> addmodule bv lid
+        )
+        cstrl
+  | Pmty_typeof m -> add_module bv m
+  | Pmty_extension e -> handle_extension e
+
+and add_module_alias bv l =
+  try
+    add_parent bv l;
+    lookup_map l.txt bv
+  with Not_found ->
+    match l.txt with
+      Lident s -> make_leaf s
+    | _ -> addmodule bv l; bound (* cannot delay *)
+
+and add_modtype_binding bv mty =
+  if not !Clflags.transparent_modules then add_modtype bv mty;
+  match mty.pmty_desc with
+    Pmty_alias l ->
+      add_module_alias bv l
+  | Pmty_signature s ->
+      make_node (add_signature_binding bv s)
+  | Pmty_typeof modl ->
+      add_module_binding bv modl
+  | _ ->
+      if !Clflags.transparent_modules then add_modtype bv mty; bound
+
+and add_signature bv sg =
+  ignore (add_signature_binding bv sg)
+
+and add_signature_binding bv sg =
+  snd (List.fold_left add_sig_item (bv, StringMap.empty) sg)
+
+and add_sig_item (bv, m) item =
+  match item.psig_desc with
+    Psig_value vd ->
+      add_type bv vd.pval_type; (bv, m)
+  | Psig_type (_, dcls) ->
+      List.iter (add_type_declaration bv) dcls; (bv, m)
+  | Psig_typext te ->
+      add_type_extension bv te; (bv, m)
+  | Psig_exception pext ->
+      add_extension_constructor bv pext; (bv, m)
+  | Psig_module pmd ->
+      let m' = add_modtype_binding bv pmd.pmd_type in
+      let add = StringMap.add pmd.pmd_name.txt m' in
+      (add bv, add m)
+  | Psig_recmodule decls ->
+      let add =
+        List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound)
+                        decls
+      in
+      let bv' = add bv and m' = add m in
+      List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
+      (bv', m')
+  | Psig_modtype x ->
+      begin match x.pmtd_type with
+        None -> ()
+      | Some mty -> add_modtype bv mty
+      end;
+      (bv, m)
+  | Psig_open od ->
+      (open_module bv od.popen_lid.txt, m)
+  | Psig_include incl ->
+      let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
+      add_names s;
+      let add = StringMap.fold StringMap.add m' in
+      (add bv, add m)
+  | Psig_class cdl ->
+      List.iter (add_class_description bv) cdl; (bv, m)
+  | Psig_class_type cdtl ->
+      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+  | Psig_attribute _ -> (bv, m)
+  | Psig_extension (e, _) ->
+      handle_extension e;
+      (bv, m)
+
+and add_module_binding bv modl =
+  if not !Clflags.transparent_modules then add_module bv modl;
+  match modl.pmod_desc with
+    Pmod_ident l ->
+      begin try
+        add_parent bv l;
+        lookup_map l.txt bv
+      with Not_found ->
+        match l.txt with
+          Lident s -> make_leaf s
+        | _ ->  addmodule bv l; bound
+      end
+  | Pmod_structure s ->
+      make_node (snd (add_structure_binding bv s))
+  | _ ->
+      if !Clflags.transparent_modules then add_module bv modl; bound
+
+and add_module bv modl =
+  match modl.pmod_desc with
+    Pmod_ident l -> addmodule bv l
+  | Pmod_structure s -> ignore (add_structure bv s)
+  | Pmod_functor(id, mty, modl) ->
+      Misc.may (add_modtype bv) mty;
+      add_module (StringMap.add id.txt bound bv) modl
+  | Pmod_apply(mod1, mod2) ->
+      add_module bv mod1; add_module bv mod2
+  | Pmod_constraint(modl, mty) ->
+      add_module bv modl; add_modtype bv mty
+  | Pmod_unpack(e) ->
+      add_expr bv e
+  | Pmod_extension e ->
+      handle_extension e
+
+and add_structure bv item_list =
+  let (bv, m) = add_structure_binding bv item_list in
+  add_names (collect_free (make_node m));
+  bv
+
+and add_structure_binding bv item_list =
+  List.fold_left add_struct_item (bv, StringMap.empty) item_list
+
+and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t =
+  match item.pstr_desc with
+    Pstr_eval (e, _attrs) ->
+      add_expr bv e; (bv, m)
+  | Pstr_value(rf, pel) ->
+      let bv = add_bindings rf bv pel in (bv, m)
+  | Pstr_primitive vd ->
+      add_type bv vd.pval_type; (bv, m)
+  | Pstr_type (_, dcls) ->
+      List.iter (add_type_declaration bv) dcls; (bv, m)
+  | Pstr_typext te ->
+      add_type_extension bv te;
+      (bv, m)
+  | Pstr_exception pext ->
+      add_extension_constructor bv pext; (bv, m)
+  | Pstr_module x ->
+      let b = add_module_binding bv x.pmb_expr in
+      let add = StringMap.add x.pmb_name.txt b in
+      (add bv, add m)
+  | Pstr_recmodule bindings ->
+      let add =
+        List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings
+      in
+      let bv' = add bv and m = add m in
+      List.iter
+        (fun x -> add_module bv' x.pmb_expr)
+        bindings;
+      (bv', m)
+  | Pstr_modtype x ->
+      begin match x.pmtd_type with
+        None -> ()
+      | Some mty -> add_modtype bv mty
+      end;
+      (bv, m)
+  | Pstr_open od ->
+      (open_module bv od.popen_lid.txt, m)
+  | Pstr_class cdl ->
+      List.iter (add_class_declaration bv) cdl; (bv, m)
+  | Pstr_class_type cdtl ->
+      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
+  | Pstr_include incl ->
+      let Node (s, m') = add_module_binding bv incl.pincl_mod in
+      add_names s;
+      let add = StringMap.fold StringMap.add m' in
+      (add bv, add m)
+  | Pstr_attribute _ -> (bv, m)
+  | Pstr_extension (e, _) ->
+      handle_extension e;
+      (bv, m)
+
+and add_use_file bv top_phrs =
+  ignore (List.fold_left add_top_phrase bv top_phrs)
+
+and add_implementation bv l =
+  if !Clflags.transparent_modules then
+    ignore (add_structure_binding bv l)
+  else ignore (add_structure bv l)
+
+and add_implementation_binding bv l =
+  snd (add_structure_binding bv l)
+
+and add_top_phrase bv = function
+  | Ptop_def str -> add_structure bv str
+  | Ptop_dir (_, _) -> bv
+
+and add_class_expr bv ce =
+  match ce.pcl_desc with
+    Pcl_constr(l, tyl) ->
+      add bv l; List.iter (add_type bv) tyl
+  | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } ->
+      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
+  | Pcl_fun(_, opte, pat, ce) ->
+      add_opt add_expr bv opte;
+      let bv = add_pattern bv pat in add_class_expr bv ce
+  | Pcl_apply(ce, exprl) ->
+      add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
+  | Pcl_let(rf, pel, ce) ->
+      let bv = add_bindings rf bv pel in add_class_expr bv ce
+  | Pcl_constraint(ce, ct) ->
+      add_class_expr bv ce; add_class_type bv ct
+  | Pcl_extension e -> handle_extension e
+
+and add_class_field bv pcf =
+  match pcf.pcf_desc with
+    Pcf_inherit(_, ce, _) -> add_class_expr bv ce
+  | Pcf_val(_, _, Cfk_concrete (_, e))
+  | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
+  | Pcf_val(_, _, Cfk_virtual ty)
+  | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
+  | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
+  | Pcf_initializer e -> add_expr bv e
+  | Pcf_attribute _ -> ()
+  | Pcf_extension e -> handle_extension e
+
+and add_class_declaration bv decl =
+  add_class_expr bv decl.pci_expr

diff --git a/parsing/depend.mli b/parsing/depend.mli
new file mode 100644 (file)
index 0000000..e34abbe
--- /dev/null
+++ b/parsing/depend.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Module dependencies. *)
+
+module StringSet : Set.S with type elt = string
+module StringMap : Map.S with type key = string
+
+type map_tree = Node of StringSet.t * bound_map
+and  bound_map = map_tree StringMap.t
+val make_leaf : string -> map_tree
+val make_node : bound_map -> map_tree
+val weaken_map : StringSet.t -> map_tree -> map_tree
+
+val free_structure_names : StringSet.t ref
+
+val open_module : bound_map -> Longident.t -> bound_map
+
+val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit
+
+val add_signature : bound_map -> Parsetree.signature -> unit
+
+val add_implementation : bound_map -> Parsetree.structure -> unit
+
+val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map
+val add_signature_binding : bound_map -> Parsetree.signature -> bound_map

diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml
index 724a499d451cd2d7955d0140e3d0a153b9dd92c4..5524aea20978386173d7a4f6d6e13545da711d36 100644 (file)
--- a/parsing/docstrings.ml
+++ b/parsing/docstrings.ml
@@ -59,7 +59,7 @@ let warn_bad_docstrings () =
       (List.rev !docstrings)
 end
 
-(* Docstring constructors and descturctors *)
+(* Docstring constructors and destructors *)
 
 let docstring body loc =
   let ds =
@@ -68,9 +68,11 @@ let docstring body loc =
       ds_attached = Unattached;
       ds_associated = Zero; }
   in
-  docstrings := ds :: !docstrings;
   ds
 
+let register ds =
+  docstrings := ds :: !docstrings
+
 let docstring_body ds = ds.ds_body
 
 let docstring_loc ds = ds.ds_loc
@@ -100,17 +102,17 @@ let docs_attr ds =
 let add_docs_attrs docs attrs =
   let attrs =
     match docs.docs_pre with
-    | None -> attrs
+    | None | Some { ds_body=""; _ } -> attrs
     | Some ds -> docs_attr ds :: attrs
   in
   let attrs =
     match docs.docs_post with
-    | None -> attrs
+    | None | Some { ds_body=""; _ } -> attrs
     | Some ds -> attrs @ [docs_attr ds]
   in
   attrs
 
-(* Docstrings attached to consturctors or fields *)
+(* Docstrings attached to constructors or fields *)
 
 type info = docstring option
 
@@ -120,7 +122,7 @@ let info_attr = docs_attr
 
 let add_info_attrs info attrs =
   match info with
-  | None -> attrs
+  | None | Some {ds_body=""; _} -> attrs
   | Some ds -> attrs @ [info_attr ds]
 
 (* Docstrings not attached to a specifc item *)
@@ -145,14 +147,15 @@ let text_attr ds =
     (text_loc, PStr [item])
 
 let add_text_attrs dsl attrs =
-  (List.map text_attr dsl) @ attrs
+  let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in
+  (List.map text_attr fdsl) @ attrs
 
 (* Find the first non-info docstring in a list, attach it and return it *)
 let get_docstring ~info dsl =
   let rec loop = function
     | [] -> None
     | {ds_attached = Info; _} :: rest -> loop rest
-    | ds :: rest ->
+    | ds :: _ ->
         ds.ds_attached <- if info then Info else Docs;
         Some ds
   in

diff --git a/parsing/docstrings.mli b/parsing/docstrings.mli
index 01103b7e3a53344974cd51bd518bfc7f562562f6..500ecbf08362530e9ff1169c9911152c1be2ef07 100644 (file)
--- a/parsing/docstrings.mli
+++ b/parsing/docstrings.mli
@@ -13,6 +13,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(** Documentation comments *)
+
 (** (Re)Initialise all docstring state *)
 val init : unit -> unit
 
@@ -27,6 +29,9 @@ type docstring
 (** Create a docstring *)
 val docstring : string -> Location.t -> docstring
 
+(** Register a docstring *)
+val register : docstring -> unit
+
 (** Get the text of a docstring *)
 val docstring_body : docstring -> string
 

diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 846745da5b791eeb0217732d0930d2418e389174..63617b48d4912d5f2e64f566cf130b145a15ddb2 100644 (file)
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -17,7 +17,7 @@
 
 val init : unit -> unit
 val token: Lexing.lexbuf -> Parser.token
-val skip_sharp_bang: Lexing.lexbuf -> unit
+val skip_hash_bang: Lexing.lexbuf -> unit
 
 type error =
   | Illegal_character of char
@@ -27,6 +27,7 @@ type error =
   | Unterminated_string_in_comment of Location.t * Location.t
   | Keyword_as_label of string
   | Invalid_literal of string
+  | Invalid_directive of string * string option
 ;;
 
 exception Error of error * Location.t

diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 0100867ec066518e48d3744cd96773e248baa13a..a485f3ed50ab9a30961dbf8ae8f493a492844d83 100644 (file)
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -28,6 +28,7 @@ type error =
   | Unterminated_string_in_comment of Location.t * Location.t
   | Keyword_as_label of string
   | Invalid_literal of string
+  | Invalid_directive of string * string option
 ;;
 
 exception Error of error * Location.t;;
@@ -260,6 +261,12 @@ let report_error ppf = function
       fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
   | Invalid_literal s ->
       fprintf ppf "Invalid literal %s" s
+  | Invalid_directive (dir, explanation) ->
+      fprintf ppf "Invalid lexer directive %S" dir;
+      begin match explanation with
+        | None -> ()
+        | Some expl -> fprintf ppf ": %s" expl
+      end
 
 let () =
   Location.register_error_of_exn
@@ -398,7 +405,7 @@ rule token = parse
         else
           COMMENT ("*" ^ s, loc)
       }
-  | "(**" ('*'+) as stars
+  | "(**" (('*'+) as stars)
       { let s, loc =
           with_comment_buffer
             (fun lexbuf ->
@@ -412,8 +419,12 @@ rule token = parse
           Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start;
         let s, loc = with_comment_buffer comment lexbuf in
         COMMENT (s, loc) }
-  | "(*" ('*'*) as stars "*)"
-      { COMMENT (stars, Location.curr lexbuf) }
+  | "(*" (('*'*) as stars) "*)"
+      { if !handle_docstrings && stars="" then
+         (* (**) is an empty docstring *)
+          DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf))
+        else
+          COMMENT (stars, Location.curr lexbuf) }
   | "*)"
       { let loc = Location.curr lexbuf in
         Location.prerr_warning loc Warnings.Comment_not_end;
@@ -422,13 +433,25 @@ rule token = parse
         lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
         STAR
       }
-  | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
-        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?
+  | ("#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
+        ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?) as directive
         [^ '\010' '\013'] * newline
-      { update_loc lexbuf name (int_of_string num) true 0;
-        token lexbuf
+      {
+        match int_of_string num with
+        | exception _ ->
+            (* PR#7165 *)
+            let loc = Location.curr lexbuf in
+            let explanation = "line number out of range" in
+            let error = Invalid_directive (directive, Some explanation) in
+            raise (Error (error, loc))
+        | line_num ->
+           (* Documentation says that the line number should be
+              positive, but we have never guarded against this and it
+              might have useful hackish uses. *)
+            update_loc lexbuf name line_num true 0;
+            token lexbuf
       }
-  | "#"  { SHARP }
+  | "#"  { HASH }
   | "&"  { AMPERSAND }
   | "&&" { AMPERAMPER }
   | "`"  { BACKQUOTE }
@@ -492,7 +515,7 @@ rule token = parse
   | ['*' '/' '%'] symbolchar *
             { INFIXOP3(Lexing.lexeme lexbuf) }
   | '#' (symbolchar | '#') +
-            { SHARPOP(Lexing.lexeme lexbuf) }
+            { HASHOP(Lexing.lexeme lexbuf) }
   | eof { EOF }
   | _
       { raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
@@ -652,7 +675,7 @@ and quoted_string delim = parse
       { store_string_char(Lexing.lexeme_char lexbuf 0);
         quoted_string delim lexbuf }
 
-and skip_sharp_bang = parse
+and skip_hash_bang = parse
   | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n"
        { update_loc lexbuf None 3 false 0 }
   | "#!" [^ '\n']* '\n'
@@ -731,15 +754,22 @@ and skip_sharp_bang = parse
           in
           loop lines' docs lexbuf
       | DOCSTRING doc ->
+          Docstrings.register doc;
           add_docstring_comment doc;
           let docs' =
-            match docs, lines with
-            | Initial, (NoLine | NewLine) -> After [doc]
-            | Initial, BlankLine -> Before([], [], [doc])
-            | After a, (NoLine | NewLine) -> After (doc :: a)
-            | After a, BlankLine -> Before (a, [], [doc])
-            | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
-            | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
+            if Docstrings.docstring_body doc = "/*" then
+              match docs with
+              | Initial -> Before([], [doc], [])
+              | After a -> Before (a, [doc], [])
+              | Before(a, f, b) -> Before(a, doc :: b @ f, [])
+            else
+              match docs, lines with
+              | Initial, (NoLine | NewLine) -> After [doc]
+              | Initial, BlankLine -> Before([], [], [doc])
+              | After a, (NoLine | NewLine) -> After (doc :: a)
+              | After a, BlankLine -> Before (a, [], [doc])
+              | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b)
+              | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc])
           in
           loop NoLine docs' lexbuf
       | tok ->

diff --git a/parsing/location.ml b/parsing/location.ml
index 96d0c0cfa0b80c1b5c1f1b39cddd70f8caf5af7f..abe47ef00357eb463f7f9b241011daaa89c40cf9 100644 (file)
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -359,14 +359,14 @@ let pp_ksprintf ?before k fmt =
       k msg)
     ppf fmt
 
-let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
-  pp_ksprintf
-    (fun msg -> {loc; msg; sub; if_highlight})
-    fmt
+(* Shift the formatter's offset by the length of the error prefix, which
+   is always added by the compiler after the message has been formatted *)
+let print_phanton_error_prefix ppf =
+  Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) ""
 
-let errorf_prefixed ?(loc=none) ?(sub=[]) ?(if_highlight="") fmt =
+let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt =
   pp_ksprintf
-    ~before:(fun ppf -> fprintf ppf "%a " print_error_prefix ())
+    ~before:print_phanton_error_prefix
     (fun msg -> {loc; msg; sub; if_highlight})
     fmt
 
@@ -390,7 +390,7 @@ let error_of_exn exn =
 let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
   let highlighted =
     if if_highlight <> "" && loc.loc_start.pos_fname = "//toplevel//" then
-      let rec collect_locs locs {loc; sub; if_highlight; _} =
+      let rec collect_locs locs {loc; sub; _} =
         List.fold_left collect_locs (loc :: locs) sub
       in
       let locs = collect_locs [] err in
@@ -401,8 +401,7 @@ let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
   if highlighted then
     Format.pp_print_string ppf if_highlight
   else begin
-    print ppf loc;
-    Format.pp_print_string ppf msg;
+    fprintf ppf "%a%a %s" print loc print_error_prefix () msg;
     List.iter (Format.fprintf ppf "@\n@[<2>%a@]" default_error_reporter) sub
   end
 
@@ -413,7 +412,7 @@ let report_error ppf err =
 ;;
 
 let error_of_printer loc print x =
-  errorf_prefixed ~loc "%a@?" print x
+  errorf ~loc "%a@?" print x
 
 let error_of_printer_file print x =
   error_of_printer (in_file !input_name) print x
@@ -422,16 +421,25 @@ let () =
   register_error_of_exn
     (function
       | Sys_error msg ->
-          Some (errorf_prefixed ~loc:(in_file !input_name)
+          Some (errorf ~loc:(in_file !input_name)
                 "I/O error: %s" msg)
       | Warnings.Errors n ->
           Some
-            (errorf_prefixed ~loc:(in_file !input_name)
+            (errorf ~loc:(in_file !input_name)
              "Some fatal warnings were triggered (%d occurrences)" n)
-      | _ ->
-          None
-    )
 
+      | Misc.HookExnWrapper {error = e; hook_name;
+                             hook_info={Misc.sourcefile}} ->
+          let sub = match error_of_exn e with
+            | None -> error (Printexc.to_string e)
+            | Some err -> err
+          in
+          Some
+            (errorf ~loc:(in_file sourcefile)
+               "In hook %S:" hook_name
+               ~sub:[sub])
+      | _ -> None
+    )
 
 external reraise : exn -> 'a = "%reraise"
 
@@ -456,4 +464,6 @@ let () =
     )
 
 let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
-  pp_ksprintf (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
+  pp_ksprintf
+    ~before:print_phanton_error_prefix
+    (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))

diff --git a/parsing/location.mli b/parsing/location.mli
index 866914ad3035c8e6923ea414f22abef408ce00d5..4a7ac9596075fe2fe7c338fa1d0fd7b3a7e85e0d 100644 (file)
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Source code locations (ranges of positions), used in parsetree. *)
+(** Source code locations (ranges of positions), used in parsetree. *)
 
 open Format
 
@@ -23,7 +23,7 @@ type t = {
   loc_ghost: bool;
 }
 
-(* Note on the use of Lexing.position in this module.
+(** Note on the use of Lexing.position in this module.
    If [pos_fname = ""], then use [!input_name] instead.
    If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and
      re-parse the file to get the line and character numbers.
@@ -112,11 +112,6 @@ val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
 val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
             -> ('a, Format.formatter, unit, error) format4 -> 'a
 
-val errorf_prefixed : ?loc:t -> ?sub:error list -> ?if_highlight:string
-                    -> ('a, Format.formatter, unit, error) format4 -> 'a
-  (* same as {!errorf}, but prints the error prefix "Error:" before yielding
-   * to the format string *)
-
 val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
             -> ('a, Format.formatter, unit, 'b) format4 -> 'a
 

diff --git a/parsing/longident.mli b/parsing/longident.mli
index 6f364a0e2da6da19c5030c91f30f6cd0f0ce2622..c7e7f3d27eedc4a5ee3d5f5d80fe84bc1c300715 100644 (file)
--- a/parsing/longident.mli
+++ b/parsing/longident.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Long identifiers, used in parsetree. *)
+(** Long identifiers, used in parsetree. *)
 
 type t =
     Lident of string

diff --git a/parsing/parse.mli b/parsing/parse.mli
index 78223a3b74bdc1c2ed4f942411c8da13a31af00e..8e6eb4544e64b82f85d3581aa60ff233ecab857f 100644 (file)
--- a/parsing/parse.mli
+++ b/parsing/parse.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Entry points in the parser *)
+(** Entry points in the parser *)
 
 val implementation : Lexing.lexbuf -> Parsetree.structure
 val interface : Lexing.lexbuf -> Parsetree.signature

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 684565fa16f098da0a2155a0e34a5198aabe3c5b..1b642b2a103c4beee282cb2eca39b7da75dcf02f 100644 (file)
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -561,8 +561,8 @@ let package_type_of_module_type pmty =
 %token RPAREN
 %token SEMI
 %token SEMISEMI
-%token SHARP
-%token <string> SHARPOP
+%token HASH
+%token <string> HASHOP
 %token SIG
 %token STAR
 %token <string * string option> STRING
@@ -639,9 +639,9 @@ The precedences must be listed from low to high.
 %nonassoc prec_unary_minus prec_unary_plus /* unary - */
 %nonassoc prec_constant_constructor     /* cf. simple_expr (C versus C x) */
 %nonassoc prec_constr_appl              /* above AS BAR COLONCOLON COMMA */
-%nonassoc below_SHARP
-%nonassoc SHARP                         /* simple_expr/toplevel_directive */
-%left     SHARPOP
+%nonassoc below_HASH
+%nonassoc HASH                         /* simple_expr/toplevel_directive */
+%left     HASHOP
 %nonassoc below_DOT
 %nonassoc DOT
 /* Finally, the first tokens of simple_expr are above everything else. */
@@ -1268,7 +1268,7 @@ class_description:
     CLASS ext_attributes virtual_flag class_type_parameters LIDENT COLON
     class_type post_item_attributes
       { let (ext, attrs) = $2 in
-        Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs@$8)
+        Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:(attrs @ $8)
             ~loc:(symbol_rloc ()) ~docs:(symbol_docs ())
       , ext }
 ;
@@ -1307,6 +1307,10 @@ seq_expr:
   | expr        %prec below_SEMI  { $1 }
   | expr SEMI                     { reloc_exp $1 }
   | expr SEMI seq_expr            { mkexp(Pexp_sequence($1, $3)) }
+  | expr SEMI PERCENT attr_id seq_expr
+      { let seq = mkexp(Pexp_sequence ($1, $5)) in
+        let payload = PStr [mkstrexp seq []] in
+        mkexp (Pexp_extension ($4, payload)) }
 ;
 labeled_simple_pattern:
     QUESTION LPAREN label_let_pattern opt_default RPAREN
@@ -1350,7 +1354,7 @@ let_pattern:
       { mkpat(Ppat_constraint($1, $3)) }
 ;
 expr:
-    simple_expr %prec below_SHARP
+    simple_expr %prec below_HASH
       { $1 }
   | simple_expr simple_labeled_expr_list
       { mkexp(Pexp_apply($1, List.rev $2)) }
@@ -1358,6 +1362,8 @@ expr:
       { expr_of_let_bindings $1 $3 }
   | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr
       { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 }
+  | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr
+      { mkexp_attrs (Pexp_letexception($4, $6)) $3 }
   | LET OPEN override_flag ext_attributes mod_longident IN seq_expr
       { mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 }
   | FUNCTION ext_attributes opt_bar match_cases
@@ -1375,9 +1381,9 @@ expr:
       { syntax_error() }
   | expr_comma_list %prec below_COMMA
       { mkexp(Pexp_tuple(List.rev $1)) }
-  | constr_longident simple_expr %prec below_SHARP
+  | constr_longident simple_expr %prec below_HASH
       { mkexp(Pexp_construct(mkrhs $1 1, Some $2)) }
-  | name_tag simple_expr %prec below_SHARP
+  | name_tag simple_expr %prec below_HASH
       { mkexp(Pexp_variant($1, Some $2)) }
   | IF ext_attributes seq_expr THEN expr ELSE expr
       { mkexp_attrs(Pexp_ifthenelse($3, $5, Some $7)) $2 }
@@ -1419,7 +1425,7 @@ expr:
   | expr EQUAL expr
       { mkinfix $1 "=" $3 }
   | expr LESS expr
-      { mkinfix $1 "<" $3 }
+    { mkinfix $1 "<" $3 }
   | expr GREATER expr
       { mkinfix $1 ">" $3 }
   | expr OR expr
@@ -1448,9 +1454,9 @@ expr:
       { bigarray_set $1 $4 $7 }
   | label LESSMINUS expr
       { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) }
-  | ASSERT ext_attributes simple_expr %prec below_SHARP
+  | ASSERT ext_attributes simple_expr %prec below_HASH
       { mkexp_attrs (Pexp_assert $3) $2 }
-  | LAZY ext_attributes simple_expr %prec below_SHARP
+  | LAZY ext_attributes simple_expr %prec below_HASH
       { mkexp_attrs (Pexp_lazy $3) $2 }
   | OBJECT ext_attributes class_structure END
       { mkexp_attrs (Pexp_object $3) $2 }
@@ -1558,9 +1564,9 @@ simple_expr:
       { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override [])))}
   | mod_longident DOT LBRACELESS field_expr_list error
       { unclosed "{<" 3 ">}" 5 }
-  | simple_expr SHARP label
+  | simple_expr HASH label
       { mkexp(Pexp_send($1, $3)) }
-  | simple_expr SHARPOP simple_expr
+  | simple_expr HASHOP simple_expr
       { mkinfix $1 $2 $3 }
   | LPAREN MODULE ext_attributes module_expr RPAREN
       { mkexp_attrs (Pexp_pack $4) $3 }
@@ -1588,19 +1594,19 @@ simple_labeled_expr_list:
       { $2 :: $1 }
 ;
 labeled_simple_expr:
-    simple_expr %prec below_SHARP
+    simple_expr %prec below_HASH
       { (Nolabel, $1) }
   | label_expr
       { $1 }
 ;
 label_expr:
-    LABEL simple_expr %prec below_SHARP
+    LABEL simple_expr %prec below_HASH
       { (Labelled $1, $2) }
   | TILDE label_ident
       { (Labelled (fst $2), snd $2) }
   | QUESTION label_ident
       { (Optional (fst $2), snd $2) }
-  | OPTLABEL simple_expr %prec below_SHARP
+  | OPTLABEL simple_expr %prec below_HASH
       { (Optional $1, $2) }
 ;
 label_ident:
@@ -1620,7 +1626,7 @@ let_binding_body:
   | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
       { let exp, poly = wrap_type_annotation $4 $6 $8 in
         (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
-  | pattern EQUAL seq_expr
+  | pattern_no_exn EQUAL seq_expr
       { ($1, $3) }
   | simple_pattern_not_ident COLON core_type EQUAL seq_expr
       { (ghpat(Ppat_constraint($1, $3)), $5) }
@@ -1726,36 +1732,58 @@ opt_type_constraint:
 /* Patterns */
 
 pattern:
-    simple_pattern
-      { $1 }
   | pattern AS val_ident
       { mkpat(Ppat_alias($1, mkrhs $3 3)) }
   | pattern AS error
       { expecting 3 "identifier" }
   | pattern_comma_list  %prec below_COMMA
       { mkpat(Ppat_tuple(List.rev $1)) }
-  | constr_longident pattern %prec prec_constr_appl
-      { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
-  | name_tag pattern %prec prec_constr_appl
-      { mkpat(Ppat_variant($1, Some $2)) }
   | pattern COLONCOLON pattern
       { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
   | pattern COLONCOLON error
       { expecting 3 "pattern" }
-  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
-      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
-  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
-      { unclosed "(" 4 ")" 8 }
   | pattern BAR pattern
       { mkpat(Ppat_or($1, $3)) }
   | pattern BAR error
       { expecting 3 "pattern" }
-  | LAZY ext_attributes simple_pattern
-      { mkpat_attrs (Ppat_lazy $3) $2}
   | EXCEPTION ext_attributes pattern %prec prec_constr_appl
       { mkpat_attrs (Ppat_exception $3) $2}
   | pattern attribute
       { Pat.attr $1 $2 }
+  | pattern_gen { $1 }
+;
+pattern_no_exn:
+  | pattern_no_exn AS val_ident
+      { mkpat(Ppat_alias($1, mkrhs $3 3)) }
+  | pattern_no_exn AS error
+      { expecting 3 "identifier" }
+  | pattern_no_exn_comma_list  %prec below_COMMA
+      { mkpat(Ppat_tuple(List.rev $1)) }
+  | pattern_no_exn COLONCOLON pattern
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
+  | pattern_no_exn COLONCOLON error
+      { expecting 3 "pattern" }
+  | pattern_no_exn BAR pattern
+      { mkpat(Ppat_or($1, $3)) }
+  | pattern_no_exn BAR error
+      { expecting 3 "pattern" }
+  | pattern_no_exn attribute
+      { Pat.attr $1 $2 }
+  | pattern_gen { $1 }
+;
+pattern_gen:
+    simple_pattern
+      { $1 }
+  | constr_longident pattern %prec prec_constr_appl
+      { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
+  | name_tag pattern %prec prec_constr_appl
+      { mkpat(Ppat_variant($1, Some $2)) }
+  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
+      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
+  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
+      { unclosed "(" 4 ")" 8 }
+  | LAZY ext_attributes simple_pattern
+      { mkpat_attrs (Ppat_lazy $3) $2}
 ;
 simple_pattern:
     val_ident %prec below_EQUAL
@@ -1773,22 +1801,24 @@ simple_pattern_not_ident:
       { mkpat(Ppat_construct(mkrhs $1 1, None)) }
   | name_tag
       { mkpat(Ppat_variant($1, None)) }
-  | SHARP type_longident
+  | HASH type_longident
       { mkpat(Ppat_type (mkrhs $2 2)) }
-  | LBRACE lbl_pattern_list RBRACE
-      { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) }
-  | LBRACE lbl_pattern_list error
-      { unclosed "{" 1 "}" 3 }
-  | LBRACKET pattern_semi_list opt_semi RBRACKET
-      { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) }
-  | LBRACKET pattern_semi_list opt_semi error
-      { unclosed "[" 1 "]" 4 }
-  | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET
-      { mkpat(Ppat_array(List.rev $2)) }
-  | LBRACKETBAR BARRBRACKET
-      { mkpat(Ppat_array []) }
-  | LBRACKETBAR pattern_semi_list opt_semi error
-      { unclosed "[|" 1 "|]" 4 }
+  | simple_delimited_pattern
+      { $1 }
+  | mod_longident DOT simple_delimited_pattern
+      { mkpat @@ Ppat_open(mkrhs $1 1, $3) }
+  | mod_longident DOT LBRACKET RBRACKET
+    { mkpat @@ Ppat_open(mkrhs $1 1, mkpat @@
+               Ppat_construct ( mkrhs (Lident "[]") 4, None)) }
+  | mod_longident DOT LPAREN RPAREN
+      { mkpat @@ Ppat_open( mkrhs $1 1, mkpat @@
+                 Ppat_construct ( mkrhs (Lident "()") 4, None) ) }
+  | mod_longident DOT LPAREN pattern RPAREN
+      { mkpat @@ Ppat_open (mkrhs $1 1, $4)}
+  | mod_longident DOT LPAREN pattern error
+      {unclosed "(" 3 ")" 5  }
+  | mod_longident DOT LPAREN error
+      { expecting 4 "pattern" }
   | LPAREN pattern RPAREN
       { reloc_pat $2 }
   | LPAREN pattern error
@@ -1812,11 +1842,32 @@ simple_pattern_not_ident:
       { mkpat(Ppat_extension $1) }
 ;
 
+simple_delimited_pattern:
+  | LBRACE lbl_pattern_list RBRACE
+    { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) }
+  | LBRACE lbl_pattern_list error
+    { unclosed "{" 1 "}" 3 }
+  | LBRACKET pattern_semi_list opt_semi RBRACKET
+    { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) }
+  | LBRACKET pattern_semi_list opt_semi error
+    { unclosed "[" 1 "]" 4 }
+  | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET
+    { mkpat(Ppat_array(List.rev $2)) }
+  | LBRACKETBAR BARRBRACKET
+    { mkpat(Ppat_array []) }
+  | LBRACKETBAR pattern_semi_list opt_semi error
+    { unclosed "[|" 1 "|]" 4 }
+
 pattern_comma_list:
     pattern_comma_list COMMA pattern            { $3 :: $1 }
   | pattern COMMA pattern                       { [$3; $1] }
   | pattern COMMA error                         { expecting 3 "pattern" }
 ;
+pattern_no_exn_comma_list:
+    pattern_no_exn_comma_list COMMA pattern     { $3 :: $1 }
+  | pattern_no_exn COMMA pattern                { [$3; $1] }
+  | pattern_no_exn COMMA error                  { expecting 3 "pattern" }
+;
 pattern_semi_list:
     pattern                                     { [$1] }
   | pattern_semi_list SEMI pattern              { $3 :: $1 }
@@ -1996,6 +2047,11 @@ sig_exception_declaration:
             ~loc:(symbol_rloc()) ~docs:(symbol_docs ())
         , ext }
 ;
+let_exception_declaration:
+    constr_ident generalized_constructor_arguments attributes
+      { let args, res = $2 in
+        Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 ~loc:(symbol_rloc()) }
+;
 generalized_constructor_arguments:
     /*empty*/                     { (Pcstr_tuple [],None) }
   | OF constructor_arguments      { ($2,None) }
@@ -2180,9 +2236,9 @@ core_type2:
 ;
 
 simple_core_type:
-    simple_core_type2  %prec below_SHARP
+    simple_core_type2  %prec below_HASH
       { $1 }
-  | LPAREN core_type_comma_list RPAREN %prec below_SHARP
+  | LPAREN core_type_comma_list RPAREN %prec below_HASH
       { match $2 with [sty] -> sty | _ -> raise Parse_error }
 ;
 
@@ -2201,11 +2257,11 @@ simple_core_type2:
       { let (f, c) = $2 in mktyp(Ptyp_object (f, c)) }
   | LESS GREATER
       { mktyp(Ptyp_object ([], Closed)) }
-  | SHARP class_longident
+  | HASH class_longident
       { mktyp(Ptyp_class(mkrhs $2 2, [])) }
-  | simple_core_type2 SHARP class_longident
+  | simple_core_type2 HASH class_longident
       { mktyp(Ptyp_class(mkrhs $3 3, [$1])) }
-  | LPAREN core_type_comma_list RPAREN SHARP class_longident
+  | LPAREN core_type_comma_list RPAREN HASH class_longident
       { mktyp(Ptyp_class(mkrhs $5 5, List.rev $2)) }
   | LBRACKET tag_field RBRACKET
       { mktyp(Ptyp_variant([$2], Closed, None)) }
@@ -2333,7 +2389,7 @@ operator:
   | INFIXOP2                                    { $1 }
   | INFIXOP3                                    { $1 }
   | INFIXOP4                                    { $1 }
-  | SHARPOP                                     { $1 }
+  | HASHOP                                     { $1 }
   | BANG                                        { "!" }
   | PLUS                                        { "+" }
   | PLUSDOT                                     { "+." }
@@ -2405,14 +2461,14 @@ class_longident:
 /* Toplevel directives */
 
 toplevel_directive:
-    SHARP ident                 { Ptop_dir($2, Pdir_none) }
-  | SHARP ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
-  | SHARP ident INT             { let (n, m) = $3 in
+    HASH ident                 { Ptop_dir($2, Pdir_none) }
+  | HASH ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
+  | HASH ident INT             { let (n, m) = $3 in
                                   Ptop_dir($2, Pdir_int (n ,m)) }
-  | SHARP ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
-  | SHARP ident mod_longident   { Ptop_dir($2, Pdir_ident $3) }
-  | SHARP ident FALSE           { Ptop_dir($2, Pdir_bool false) }
-  | SHARP ident TRUE            { Ptop_dir($2, Pdir_bool true) }
+  | HASH ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
+  | HASH ident mod_longident   { Ptop_dir($2, Pdir_ident $3) }
+  | HASH ident FALSE           { Ptop_dir($2, Pdir_bool false) }
+  | HASH ident TRUE            { Ptop_dir($2, Pdir_bool true) }
 ;
 
 /* Miscellaneous */

diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d3796f788eb2f2a290973fdd836b0b20fabe61e3..d61b3392b4611567ffb031e378314672e8748129 100644 (file)
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -220,6 +220,7 @@ and pattern_desc =
         (* exception P *)
   | Ppat_extension of extension
         (* [%id] *)
+  | Ppat_open of Longident.t loc * pattern
 
 (* Value expressions *)
 
@@ -318,6 +319,8 @@ and expression_desc =
         (* {< x1 = E1; ...; Xn = En >} *)
   | Pexp_letmodule of string loc * module_expr * expression
         (* let module M = ME in E *)
+  | Pexp_letexception of extension_constructor * expression
+        (* let exception C in E *)
   | Pexp_assert of expression
         (* assert E
            Note: "assert false" is treated in a special way by the

diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 90bfaa514c04cff0ba2daf98e5cca4f9f04afdf4..f9e51522433571ade759f75a6e66a8e0d716e619 100644 (file)
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -30,7 +30,7 @@ open Parsetree
 let prefix_symbols  = [ '!'; '?'; '~' ] ;;
 let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
                       '$'; '%' ]
-
+(* type fixity = Infix| Prefix  *)
 let special_infix_strings =
   ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ]
 
@@ -122,176 +122,185 @@ let is_simple_construct :construct -> bool = function
 
 let pp = fprintf
 
-class printer  ()= object(self:'self)
-  val pipe = false
-  val semi = false
-  val ifthenelse = false
-  method under_pipe = {<pipe=true>}
-  method under_semi = {<semi=true>}
-  method under_ifthenelse = {<ifthenelse=true>}
-  method reset_semi = {<semi=false>}
-  method reset_ifthenelse = {<ifthenelse=false>}
-  method reset_pipe = {<pipe=false>}
-  method reset = {<pipe=false;semi=false;ifthenelse=false>}
-  method list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
-    ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
-    Format.formatter -> 'a list -> unit
-        = fun  ?sep ?first  ?last fu f xs ->
-          let first = match first with Some x -> x |None -> ("" : _ format6)
-          and last = match last with Some x -> x |None -> ("" : _ format6)
-          and sep = match sep with Some x -> x |None -> ("@ " : _ format6) in
-          let aux f = function
-            | [] -> ()
+type ctxt = {
+  pipe : bool;
+  semi : bool;
+  ifthenelse : bool;
+}
+
+let reset_ctxt = { pipe=false; semi=false; ifthenelse=false }
+let under_pipe ctxt = { ctxt with pipe=true }
+let under_semi ctxt = { ctxt with semi=true }
+let under_ifthenelse ctxt = { ctxt with ifthenelse=true }
+(*
+let reset_semi ctxt = { ctxt with semi=false }
+let reset_ifthenelse ctxt = { ctxt with ifthenelse=false }
+let reset_pipe ctxt = { ctxt with pipe=false }
+*)
+
+let list : 'a . ?sep:space_formatter -> ?first:space_formatter ->
+  ?last:space_formatter -> (Format.formatter -> 'a -> unit) ->
+  Format.formatter -> 'a list -> unit
+  = fun ?sep ?first ?last fu f xs ->
+    let first = match first with Some x -> x |None -> ("": _ format6)
+    and last = match last with Some x -> x |None -> ("": _ format6)
+    and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in
+    let aux f = function
+      | [] -> ()
+      | [x] -> fu f x
+      | xs ->
+          let rec loop  f = function
             | [x] -> fu f x
-            | xs ->
-                let rec loop  f = function
-                  | [x] -> fu f x
-                  | x::xs ->  fu f x; pp f sep; loop f xs;
-                  | _ -> assert false in begin
-                      pp f first; loop f xs; pp f last;
-                  end in
-          aux f xs
-  method option : 'a. ?first:space_formatter -> ?last:space_formatter ->
-    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit =
-      fun  ?first  ?last fu f a ->
-        let first = match first with Some x -> x | None -> ("" : _ format6)
-        and last = match last with Some x -> x | None -> ("" : _ format6) in
-        match a with
-        | None -> ()
-        | Some x -> pp f first; fu f x; pp f last;
-  method paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
-    bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit =
-    fun  ?(first=("" : _ format6)) ?(last=("" : _ format6)) b fu f x ->
-      if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
-      else fu f x
-
-
-  method longident f = function
-    | Lident s -> protect_ident f s
-    | Ldot(y,s) -> protect_longident f self#longident y s
-    | Lapply (y,s) ->
-        pp f "%a(%a)" self#longident y self#longident s
-  method longident_loc f x = pp f "%a" self#longident x.txt
-  method constant f  = function
-    | Pconst_char i -> pp f "%C"  i
-    | Pconst_string (i, None) -> pp f "%S" i
-    | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
-    | Pconst_integer (i,None) -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i
-    | Pconst_integer (i,Some m) ->
-        self#paren (i.[0]='-') (fun f (i,m) -> pp f "%s%c" i m) f (i,m)
-    | Pconst_float (i,None) -> self#paren (i.[0]='-') (fun f -> pp f "%s") f i
-    | Pconst_float (i, Some m) -> self#paren (i.[0]='-') (fun f (i,m) ->
-        pp f "%s%c" i m) f (i,m)
-
-  (* trailing space*)
-  method mutable_flag f   = function
-    | Immutable -> ()
-    | Mutable -> pp f "mutable@;"
-  method virtual_flag f  = function
-    | Concrete -> ()
-    | Virtual -> pp f "virtual@;"
-
-  (* trailing space added *)
-  method rec_flag f rf =
-    match rf with
-    | Nonrecursive -> ()
-    | Recursive -> pp f "rec "
-  method nonrec_flag f rf =
-    match rf with
-    | Nonrecursive -> pp f "nonrec "
-    | Recursive -> ()
-  method direction_flag f = function
-    | Upto -> pp f "to@ "
-    | Downto -> pp f "downto@ "
-  method private_flag f = function
-    | Public -> ()
-    | Private -> pp f "private@ "
-
-  method constant_string f s = pp f "%S" s
-  method tyvar f str = pp f "'%s" str
-  method string_quot f x = pp f "`%s" x
-
-          (* c ['a,'b] *)
-  method class_params_def f =  function
-    | [] -> ()
-    | l ->
-        pp f "[%a] " (* space *)
-          (self#list self#type_param ~sep:",") l
-
-  method type_with_label f (label,({ptyp_desc;_}as c) ) =
-    match label with
-    | Nolabel ->  self#core_type1 f c (* otherwise parenthesize *)
-    | Labelled s -> pp f "%s:%a" s self#core_type1 c
-    | Optional s -> pp f "?%s:%a" s self#core_type1 c
-  method core_type f x =
-    if x.ptyp_attributes <> [] then begin
-      pp f "((%a)%a)" self#core_type {x with ptyp_attributes=[]}
-        self#attributes x.ptyp_attributes
-    end
-    else match x.ptyp_desc with
+            | x::xs ->  fu f x; pp f sep; loop f xs;
+            | _ -> assert false in begin
+            pp f first; loop f xs; pp f last;
+          end in
+    aux f xs
+
+let option : 'a. ?first:space_formatter -> ?last:space_formatter ->
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit
+  = fun  ?first  ?last fu f a ->
+    let first = match first with Some x -> x | None -> ("": _ format6)
+    and last = match last with Some x -> x | None -> ("": _ format6) in
+    match a with
+    | None -> ()
+    | Some x -> pp f first; fu f x; pp f last
+
+let paren: 'a . ?first:space_formatter -> ?last:space_formatter ->
+  bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
+  = fun  ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x ->
+    if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")")
+    else fu f x
+
+let rec longident f = function
+  | Lident s -> protect_ident f s
+  | Ldot(y,s) -> protect_longident f longident y s
+  | Lapply (y,s) ->
+      pp f "%a(%a)" longident y longident s
+
+let longident_loc f x = pp f "%a" longident x.txt
+
+let constant f = function
+  | Pconst_char i -> pp f "%C"  i
+  | Pconst_string (i, None) -> pp f "%S" i
+  | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim
+  | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
+  | Pconst_integer (i, Some m) ->
+    paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m)
+  | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i
+  | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) ->
+      pp f "%s%c" i m) f (i,m)
+
+(* trailing space*)
+let mutable_flag f = function
+  | Immutable -> ()
+  | Mutable -> pp f "mutable@;"
+let virtual_flag f  = function
+  | Concrete -> ()
+  | Virtual -> pp f "virtual@;"
+
+(* trailing space added *)
+let rec_flag f rf =
+  match rf with
+  | Nonrecursive -> ()
+  | Recursive -> pp f "rec "
+let nonrec_flag f rf =
+  match rf with
+  | Nonrecursive -> pp f "nonrec "
+  | Recursive -> ()
+let direction_flag f = function
+  | Upto -> pp f "to@ "
+  | Downto -> pp f "downto@ "
+let private_flag f = function
+  | Public -> ()
+  | Private -> pp f "private@ "
+
+let constant_string f s = pp f "%S" s
+let tyvar f str = pp f "'%s" str
+let string_quot f x = pp f "`%s" x
+
+(* c ['a,'b] *)
+let rec class_params_def ctxt f =  function
+  | [] -> ()
+  | l ->
+      pp f "[%a] " (* space *)
+        (list (type_param ctxt) ~sep:",") l
+
+and type_with_label ctxt f (label, c) =
+  match label with
+  | Nolabel    -> core_type1 ctxt f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
+  | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
+
+and core_type ctxt f x =
+  if x.ptyp_attributes <> [] then begin
+    pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]}
+      (attributes ctxt) x.ptyp_attributes
+  end
+  else match x.ptyp_desc with
     | Ptyp_arrow (l, ct1, ct2) ->
         pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
-          self#type_with_label (l,ct1) self#core_type ct2
+          (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
     | Ptyp_alias (ct, s) ->
-        pp f "@[<2>%a@;as@;'%s@]" self#core_type1 ct s
+        pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s
     | Ptyp_poly (sl, ct) ->
         pp f "@[<2>%a%a@]"
           (fun f l ->
-            pp f "%a"
-              (fun f l -> match l with
-              | [] -> ()
-              | _ ->
-                  pp f "%a@;.@;"
-                    (self#list self#tyvar ~sep:"@;")  l)
-              l)
-          sl  self#core_type ct
-    | _ -> pp f "@[<2>%a@]" self#core_type1 x
-  method core_type1 f x =
-    if x.ptyp_attributes <> [] then self#core_type f x
-    else match x.ptyp_desc with
+             pp f "%a"
+               (fun f l -> match l with
+                  | [] -> ()
+                  | _ ->
+                      pp f "%a@;.@;"
+                        (list tyvar ~sep:"@;")  l)
+               l)
+          sl (core_type ctxt) ct
+    | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x
+
+and core_type1 ctxt f x =
+  if x.ptyp_attributes <> [] then core_type ctxt f x
+  else match x.ptyp_desc with
     | Ptyp_any -> pp f "_";
-    | Ptyp_var s -> self#tyvar f  s;
-    | Ptyp_tuple l ->  pp f "(%a)" (self#list self#core_type1 ~sep:"*@;") l
+    | Ptyp_var s -> tyvar f  s;
+    | Ptyp_tuple l ->  pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l
     | Ptyp_constr (li, l) ->
         pp f (* "%a%a@;" *) "%a%a"
           (fun f l -> match l with
-          |[] -> ()
-          |[x]-> pp f "%a@;" self#core_type1  x
-          | _ -> self#list ~first:"(" ~last:")@;" self#core_type ~sep:"," f l)
-          l self#longident_loc li
+             |[] -> ()
+             |[x]-> pp f "%a@;" (core_type1 ctxt)  x
+             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:"," f l)
+          l longident_loc li
     | Ptyp_variant (l, closed, low) ->
         let type_variant_helper f x =
           match x with
-          | Rtag (l, attrs, _, ctl) -> pp f "@[<2>%a%a@;%a@]" self#string_quot l
+          | Rtag (l, attrs, _, ctl) ->
+              pp f "@[<2>%a%a@;%a@]" string_quot l
                 (fun f l -> match l with
-                |[] -> ()
-                | _ -> pp f "@;of@;%a"
-                      (self#list self#core_type ~sep:"&")  ctl) ctl
-                self#attributes attrs
-          | Rinherit ct -> self#core_type f ct in
+                   |[] -> ()
+                   | _ -> pp f "@;of@;%a"
+                            (list (core_type ctxt) ~sep:"&")  ctl) ctl
+                (attributes ctxt) attrs
+          | Rinherit ct -> core_type ctxt f ct in
         pp f "@[<2>[%a%a]@]"
-          (fun f l
-            ->
-              match l with
-              | [] -> ()
-              | _ ->
-              pp f "%s@;%a"
-                (match (closed,low) with
-                | (Closed,None) -> ""
-                | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
-                | (Open,_) -> ">")
-                (self#list type_variant_helper ~sep:"@;<1 -2>| ") l) l
-          (fun f low
-            ->
-              match low with
-              |Some [] |None -> ()
-              |Some xs ->
-              pp f ">@ %a"
-                (self#list self#string_quot) xs) low
+          (fun f l ->
+             match l, closed with
+             | [], Closed -> ()
+             | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *)
+             | _ ->
+                 pp f "%s@;%a"
+                   (match (closed,low) with
+                    | (Closed,None) -> ""
+                    | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*)
+                    | (Open,_) -> ">")
+                   (list type_variant_helper ~sep:"@;<1 -2>| ") l) l
+          (fun f low -> match low with
+             |Some [] |None -> ()
+             |Some xs ->
+                 pp f ">@ %a"
+                   (list string_quot) xs) low
     | Ptyp_object (l, o) ->
         let core_field_type f (s, attrs, ct) =
-          pp f "@[<hov2>%s%a@ :%a@ @]" s
-             self#attributes attrs self#core_type ct
+          pp f "@[<hov2>%s: %a@ %a@ @]" s
+            (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
         in
         let field_var f = function
           | Asttypes.Closed -> ()
@@ -300,257 +309,277 @@ class printer  ()= object(self:'self)
               | [] -> pp f ".."
               | _ -> pp f " ;.."
         in
-        pp f "@[<hov2><@ %a%a@ >@]" (self#list core_field_type ~sep:";") l
-          field_var o
+        pp f "@[<hov2><@ %a%a@ > @]" (list core_field_type ~sep:";") l
+          field_var o (* Cf #7200 *)
     | Ptyp_class (li, l) ->   (*FIXME*)
         pp f "@[<hov2>%a#%a@]"
-          (self#list self#core_type ~sep:"," ~first:"(" ~last:")") l
-          self#longident_loc li
+          (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
+          longident_loc li
     | Ptyp_package (lid, cstrs) ->
         let aux f (s, ct) =
-          pp f "type %a@ =@ %a" self#longident_loc s self#core_type ct  in
+          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
         (match cstrs with
-        |[] -> pp f "@[<hov2>(module@ %a)@]" self#longident_loc lid
-        |_ ->
-            pp f "@[<hov2>(module@ %a@ with@ %a)@]" self#longident_loc lid
-              (self#list aux  ~sep:"@ and@ ")  cstrs)
-    | Ptyp_extension e -> self#extension f e
-    | _ -> self#paren true self#core_type f x
-          (********************pattern********************)
-          (* be cautious when use [pattern], [pattern1] is preferred *)
-  method pattern f x =
-    let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
-      | {ppat_desc= Ppat_or (p1,p2);_} ->
-          list_of_pattern  (p2::acc) p1
-      | x -> x::acc in
-    if x.ppat_attributes <> [] then begin
-      pp f "((%a)%a)" self#pattern {x with ppat_attributes=[]}
-        self#attributes x.ppat_attributes
-    end
-    else match x.ppat_desc with
-    | Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]"
-          self#pattern p protect_ident s.txt (* RA*)
-    | Ppat_or (p1, p2) -> (* *)
-        pp f "@[<hov0>%a@]" (self#list ~sep:"@,|" self#pattern)
-           (list_of_pattern [] x)
-    | _ -> self#pattern1 f x
-  method pattern1 (f:Format.formatter) (x:pattern) :unit =
-    let rec pattern_list_helper f  =  function
-      | {ppat_desc =
+         |[] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
+         |_ ->
+             pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
+               (list aux  ~sep:"@ and@ ")  cstrs)
+    | Ptyp_extension e -> extension ctxt f e
+    | _ -> paren true (core_type ctxt) f x
+
+(********************pattern********************)
+(* be cautious when use [pattern], [pattern1] is preferred *)
+and pattern ctxt f x =
+  let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
+    | {ppat_desc= Ppat_or (p1,p2);_} ->
+        list_of_pattern  (p2::acc) p1
+    | x -> x::acc
+  in
+  if x.ppat_attributes <> [] then begin
+    pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]}
+      (attributes ctxt) x.ppat_attributes
+  end
+  else match x.ppat_desc with
+    | Ppat_alias (p, s) ->
+        pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*)
+    | Ppat_or _ -> (* *)
+        pp f "@[<hov0>%a@]" (list ~sep:"@,|" (pattern ctxt))
+          (list_of_pattern [] x)
+    | _ -> pattern1 ctxt f x
+
+and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
+  let rec pattern_list_helper f = function
+    | {ppat_desc =
          Ppat_construct
            ({ txt = Lident("::") ;_},
             Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); _}
-        -> pp f "%a::%a"  self#simple_pattern  pat1  pattern_list_helper pat2
-            (*RA*)
-      | p -> self#pattern1 f p in
-    if x.ppat_attributes <> [] then self#pattern f x
-    else match x.ppat_desc with
-    | Ppat_variant (l, Some p) ->  pp f "@[<2>`%s@;%a@]" l self#simple_pattern p
-    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> self#simple_pattern f x
+      ->
+        pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
+    | p -> pattern1 ctxt f p
+  in
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
+    | Ppat_variant (l, Some p) ->
+        pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p
+    | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x
     | Ppat_construct (({txt;_} as li), po) ->
         (* FIXME The third field always false *)
         if txt = Lident "::" then
           pp f "%a" pattern_list_helper x
         else
           (match po with
-          |Some x ->
-              pp f "%a@;%a"  self#longident_loc li self#simple_pattern x
-          | None -> pp f "%a@;"self#longident_loc li )
-    | _ -> self#simple_pattern f x
-  method simple_pattern (f:Format.formatter) (x:pattern) :unit =
-    if x.ppat_attributes <> [] then self#pattern f x
-    else match x.ppat_desc with
+           | Some x -> pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
+           | None -> pp f "%a@;"longident_loc li )
+    | _ -> simple_pattern ctxt f x
+
+and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
+  if x.ppat_attributes <> [] then pattern ctxt f x
+  else match x.ppat_desc with
     | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f  "%s" x
     | Ppat_any -> pp f "_";
     | Ppat_var ({txt = txt;_}) -> protect_ident f txt
     | Ppat_array l ->
-        pp f "@[<2>[|%a|]@]"  (self#list self#pattern1 ~sep:";") l
+        pp f "@[<2>[|%a|]@]"  (list (pattern1 ctxt) ~sep:";") l
     | Ppat_unpack (s) ->
         pp f "(module@ %s)@ " s.txt
     | Ppat_type li ->
-        pp f "#%a" self#longident_loc li
+        pp f "#%a" longident_loc li
     | Ppat_record (l, closed) ->
         let longident_x_pattern f (li, p) =
           match (li,p.ppat_desc) with
           | ({txt=Lident s;_ },Ppat_var {txt;_} ) when s = txt ->
-              pp f "@[<2>%a@]"  self#longident_loc li
+              pp f "@[<2>%a@]"  longident_loc li
           | _ ->
-            pp f "@[<2>%a@;=@;%a@]" self#longident_loc li self#pattern1 p in
-        (match closed with
-        |Closed ->
-            pp f "@[<2>{@;%a@;}@]"
-              (self#list longident_x_pattern ~sep:";@;") l
+              pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
+        in
+        begin match closed with
+        | Closed ->
+            pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l
         | _ ->
-            pp f "@[<2>{@;%a;_}@]"
-              (self#list longident_x_pattern ~sep:";@;") l)
-    | Ppat_tuple l -> pp f "@[<1>(%a)@]" (self#list  ~sep:"," self#pattern1)  l
-                      (* level1*)
-    | Ppat_constant (c) -> pp f "%a" self#constant c
-    | Ppat_interval (c1, c2) -> pp f "%a..%a" self#constant c1 self#constant c2
+            pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
+        end
+    | Ppat_tuple l ->
+        pp f "@[<1>(%a)@]" (list  ~sep:"," (pattern1 ctxt))  l (* level1*)
+    | Ppat_constant (c) -> pp f "%a" constant c
+    | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
     | Ppat_variant (l,None) ->  pp f "`%s" l
     | Ppat_constraint (p, ct) ->
-        pp f "@[<2>(%a@;:@;%a)@]" self#pattern1 p self#core_type ct
+        pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct
     | Ppat_lazy p ->
-        pp f "@[<2>(lazy@;%a)@]" self#pattern1 p
+        pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p
     | Ppat_exception p ->
-        pp f "@[<2>exception@;%a@]" self#pattern1 p
-    | Ppat_extension e -> self#extension f e
-    | _ -> self#paren true self#pattern f x
-
-  method label_exp f (l,opt,p) =
-    match l with
-    | Nolabel ->
-      pp f "%a@ " self#simple_pattern p
-        (*single case pattern parens needed here *)
-    | Optional rest ->
-        begin match p.ppat_desc with
-          | Ppat_var {txt;_} when txt = rest ->
-              (match opt with
-               | Some o -> pp f "?(%s=@;%a)@;" rest  self#expression o
-               | None -> pp f "?%s@ " rest)
-          | _ ->
-              (match opt with
-               | Some o ->
-                   pp f "?%s:(%a=@;%a)@;" rest self#pattern1 p self#expression o
-               | None -> pp f "?%s:%a@;" rest self#simple_pattern p)
-        end
-    | Labelled l ->
-        (match p.ppat_desc with
-        | Ppat_var {txt;_} when txt = l ->
-            pp f "~%s@;" l
-        | _ ->  pp f "~%s:%a@;" l self#simple_pattern p )
-  method sugar_expr f e =
-    if e.pexp_attributes <> [] then false
-    else match e.pexp_desc with
-    | Pexp_apply ({ pexp_desc = Pexp_ident { txt = id; _ };
-                    pexp_attributes=[]; _ }, args)
-      when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
-        match id, List.map snd args with
-        | Lident "!", [e] ->
-          pp f "@[<hov>!%a@]" self#simple_expr e;
-          true
-        | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
-            let print left right print_index indexes rem_args =
-              match func, rem_args with
-              | "get", [] ->
-                pp f "@[%a.%s%a%s@]"
-                  self#simple_expr a
-                  left (self#list ~sep:"," print_index) indexes right;
-                true
-              | "set", [v] ->
-                pp f "@[%a.%s%a%s@ <-@;<1 2>%a@]"
-                  self#simple_expr a
-                  left (self#list ~sep:"," print_index) indexes right
-                  self#simple_expr v;
-                true
-              | _ -> false
-            in
-            match path, other_args with
-            | Lident "Array", i :: rest ->
-              print "(" ")" self#expression [i] rest
-            | Lident "String", i :: rest ->
-              print "[" "]" self#expression [i] rest
-            | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
-              print "{" "}" self#simple_expr [i1] rest
-            | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
-              print "{" "}" self#simple_expr [i1; i2] rest
-            | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
-              print "{" "}" self#simple_expr [i1; i2; i3] rest
-            | Ldot (Lident "Bigarray", "Genarray"),
-              {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
-              print "{" "}" self#simple_expr indexes rest
-            | _ -> false
-          end
-        | _ -> false
+        pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p
+    | Ppat_extension e -> extension ctxt f e
+    | Ppat_open (lid, p) ->
+        let with_paren =
+        match p.ppat_desc with
+        | Ppat_array _ | Ppat_record _
+        | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false
+        | _ -> true in
+        pp f "@[<2>%a.%a @]" longident_loc lid
+          (paren with_paren @@ pattern1 ctxt) p
+    | _ -> paren true (pattern ctxt) f x
+
+and label_exp ctxt f (l,opt,p) =
+  match l with
+  | Nolabel ->
+      (* single case pattern parens needed here *)
+      pp f "%a@ " (simple_pattern ctxt) p
+  | Optional rest ->
+      begin match p.ppat_desc with
+      | Ppat_var {txt;_} when txt = rest ->
+          (match opt with
+           | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
+           | None -> pp f "?%s@ " rest)
+      | _ ->
+          (match opt with
+           | Some o ->
+               pp f "?%s:(%a=@;%a)@;"
+                 rest (pattern1 ctxt) p (expression ctxt) o
+           | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
       end
-    | _ -> false
-  method expression f x =
-    if x.pexp_attributes <> [] then begin
-      pp f "((%a)@,%a)" self#expression {x with pexp_attributes=[]}
-        self#attributes x.pexp_attributes
+  | Labelled l -> match p.ppat_desc with
+    | Ppat_var {txt;_} when txt = l ->
+        pp f "~%s@;" l
+    | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p
+
+and sugar_expr ctxt f e =
+  if e.pexp_attributes <> [] then false
+  else match e.pexp_desc with
+  | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
+                  pexp_attributes=[]; _}, args)
+    when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
+      match id, List.map snd args with
+      | Lident "!", [e] ->
+        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
+      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
+          let print left right print_index indexes rem_args =
+            match func, rem_args with
+            | "get", [] ->
+              pp f "@[%a.%s%a%s@]"
+                (simple_expr ctxt) a
+                left (list ~sep:"," print_index) indexes right; true
+            | "set", [v] ->
+              pp f "@[%a.%s%a%s@ <-@;<1 2>%a@]"
+                (simple_expr ctxt) a
+                left (list ~sep:"," print_index) indexes right
+                (simple_expr ctxt) v; true
+            | _ -> false
+          in
+          match path, other_args with
+          | Lident "Array", i :: rest ->
+            print "(" ")" (expression ctxt) [i] rest
+          | Lident "String", i :: rest ->
+            print "[" "]" (expression ctxt) [i] rest
+          | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1] rest
+          | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1; i2] rest
+          | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
+            print "{" "}" (simple_expr ctxt) [i1; i2; i3] rest
+          | Ldot (Lident "Bigarray", "Genarray"),
+            {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
+            print "{" "}" (simple_expr ctxt) indexes rest
+          | _ -> false
+        end
+      | _ -> false
     end
-    else match x.pexp_desc with
+  | _ -> false
+
+and expression ctxt f x =
+  if x.pexp_attributes <> [] then
+    pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]}
+      (attributes ctxt) x.pexp_attributes
+  else match x.pexp_desc with
     | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
-      when pipe || semi ->
-        self#paren true self#reset#expression f x
-    | Pexp_ifthenelse _ | Pexp_sequence _ when ifthenelse ->
-        self#paren true self#reset#expression f x
-    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ when semi ->
-        self#paren true self#reset#expression f x
+      when ctxt.pipe || ctxt.semi ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse ->
+        paren true (expression reset_ctxt) f x
+    | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _
+        when ctxt.semi ->
+        paren true (expression reset_ctxt) f x
     | Pexp_fun (l, e0, p, e) ->
         pp f "@[<2>fun@;%a@;->@;%a@]"
-          self#label_exp (l, e0, p)
-          self#expression e
+          (label_exp ctxt) (l, e0, p)
+          (expression ctxt) e
     | Pexp_function l ->
-        pp f "@[<hv>function%a@]" self#case_list l
+        pp f "@[<hv>function%a@]" (case_list ctxt) l
     | Pexp_match (e, l) ->
-        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]" self#reset#expression
-           e self#case_list l
+        pp f "@[<hv0>@[<hv0>@[<2>match %a@]@ with@]%a@]"
+          (expression reset_ctxt) e (case_list ctxt) l
 
     | Pexp_try (e, l) ->
         pp f "@[<0>@[<hv2>try@ %a@]@ @[<0>with%a@]@]"
-          (* "try@;@[<2>%a@]@\nwith@\n%a"*)
-          self#reset#expression e  self#case_list l
+             (* "try@;@[<2>%a@]@\nwith@\n%a"*)
+          (expression reset_ctxt) e  (case_list ctxt) l
     | Pexp_let (rf, l, e) ->
         (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
            (*no identation here, a new line*) *)
-        (*   self#rec_flag rf *)
+        (*   rec_flag rf *)
         pp f "@[<2>%a in@;<1 -2>%a@]"
-          self#reset#bindings (rf,l)
-          self#expression e
+          (bindings reset_ctxt) (rf,l)
+          (expression ctxt) e
     | Pexp_apply (e, l) ->
-        (if not (self#sugar_expr f x) then
-          match view_fixity_of_exp e with
-          | `Infix s ->
-            (match l with
-            | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
-                pp f "@[<2>%a@;%s@;%a@]"
-                   (* FIXME associativity lable_x_expression_parm*)
-                   self#reset#label_x_expression_param  arg1 s
-                   self#label_x_expression_param arg2
+        begin if not (sugar_expr ctxt f x) then
+            match view_fixity_of_exp e with
+            | `Infix s ->
+                begin match l with
+                | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] ->
+                    (* FIXME associativity label_x_expression_param *)
+                    pp f "@[<2>%a@;%s@;%a@]"
+                      (label_x_expression_param reset_ctxt) arg1 s
+                      (label_x_expression_param ctxt) arg2
+                | _ ->
+                    pp f "@[<2>%a %a@]"
+                      (simple_expr ctxt) e
+                      (list (label_x_expression_param ctxt)) l
+                end
+            | `Prefix s ->
+                let s =
+                  if List.mem s ["~+";"~-";"~+.";"~-."] &&
+                   (match l with
+                    (* See #7200: avoid turning (~- 1) into (- 1) which is
+                       parsed as an int literal *)
+                    |[(_,{pexp_desc=Pexp_constant _})] -> false
+                    | _ -> true)
+                  then String.sub s 1 (String.length s -1)
+                  else s in
+                begin match l with
+                | [(Nolabel, _) as v] ->
+                  pp f "@[<2>%s@;%a@]" s (label_x_expression_param ctxt) v
+                | _   ->
+                  pp f "@[<2>%a %a@]" (simple_expr ctxt) e
+                    (list (label_x_expression_param ctxt)) l
+                end
             | _ ->
-                pp f "@[<2>%a %a@]" self#simple_expr e
-                   (self#list self#label_x_expression_param)  l)
-          | `Prefix s ->
-              let s =
-                if List.mem s ["~+";"~-";"~+.";"~-."]
-                then String.sub s 1 (String.length s -1)
-                else s
-            in
-            (match l with
-            | [(Nolabel, _) as v] ->
-              pp f "@[<2>%s@;%a@]" s self#label_x_expression_param v
-            | _ ->
-              pp f "@[<2>%a %a@]" self#simple_expr e
-                (self#list self#label_x_expression_param) l
-            )
-          | _ ->
-            pp f "@[<hov2>%a@]" begin fun f (e,l) ->
-              pp f "%a@ %a" self#expression2 e
-                (self#list self#reset#label_x_expression_param) l
-               (*reset here only because [function,match,try,sequence] are
-                 lower priority*)
-            end (e,l))
+                pp f "@[<hov2>%a@]" begin fun f (e,l) ->
+                  pp f "%a@ %a" (expression2 ctxt) e
+                    (list (label_x_expression_param reset_ctxt))  l
+                    (* reset here only because [function,match,try,sequence]
+                       are lower priority *)
+                end (e,l)
+        end
 
     | Pexp_construct (li, Some eo)
       when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*)
         (match view_expr x with
-        | `cons ls -> self#list self#simple_expr f ls ~sep:"@;::@;"
-        | `normal ->
-            pp f "@[<2>%a@;%a@]" self#longident_loc li
-              self#simple_expr  eo
-        | _ -> assert false)
+         | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;"
+         | `normal ->
+             pp f "@[<2>%a@;%a@]" longident_loc li
+               (simple_expr ctxt) eo
+         | _ -> assert false)
     | Pexp_setfield (e1, li, e2) ->
-        pp f "@[<2>%a.%a@ <-@ %a@]" self#simple_expr  e1  self#longident_loc li
-           self#expression e2;
+        pp f "@[<2>%a.%a@ <-@ %a@]"
+          (simple_expr ctxt) e1 longident_loc li (expression ctxt) e2
     | Pexp_ifthenelse (e1, e2, eo) ->
         (* @;@[<2>else@ %a@]@] *)
         let fmt:(_,_,_)format ="@[<hv0>@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in
-        pp f fmt  self#under_ifthenelse#expression e1
-           self#under_ifthenelse#expression e2
+        let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in
+        pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2
           (fun f eo -> match eo with
-          | Some x -> pp f "@;@[<2>else@;%a@]" self#under_semi#expression  x
-          | None -> () (* pp f "()" *)) eo
+             | Some x ->
+                 pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x
+             | None -> () (* pp f "()" *)) eo
     | Pexp_sequence _ ->
         let rec sequence_helper acc = function
           | {pexp_desc=Pexp_sequence(e1,e2);_} ->
@@ -558,864 +587,860 @@ class printer  ()= object(self:'self)
           | v -> List.rev (v::acc) in
         let lst = sequence_helper [] x in
         pp f "@[<hv>%a@]"
-          (self#list self#under_semi#expression ~sep:";@;") lst
+          (list (expression (under_semi ctxt)) ~sep:";@;") lst
     | Pexp_new (li) ->
-        pp f "@[<hov2>new@ %a@]" self#longident_loc li;
+        pp f "@[<hov2>new@ %a@]" longident_loc li;
     | Pexp_setinstvar (s, e) ->
-        pp f "@[<hov2>%s@ <-@ %a@]" s.txt self#expression e
+        pp f "@[<hov2>%s@ <-@ %a@]" s.txt (expression ctxt) e
     | Pexp_override l -> (* FIXME *)
         let string_x_expression f (s, e) =
-          pp f "@[<hov2>%s@ =@ %a@]" s.txt self#expression e in
+          pp f "@[<hov2>%s@ =@ %a@]" s.txt (expression ctxt) e in
         pp f "@[<hov2>{<%a>}@]"
-          (self#list string_x_expression  ~sep:";"  )  l;
+          (list string_x_expression  ~sep:";"  )  l;
     | Pexp_letmodule (s, me, e) ->
         pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
-          self#reset#module_expr me  self#expression e
+          (module_expr reset_ctxt) me (expression ctxt) e
+    | Pexp_letexception (cd, e) ->
+        pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
+          (extension_constructor ctxt) cd
+          (expression ctxt) e
     | Pexp_assert e ->
-        pp f "@[<hov2>assert@ %a@]" self#simple_expr e
+        pp f "@[<hov2>assert@ %a@]" (simple_expr ctxt) e
     | Pexp_lazy (e) ->
-        pp f "@[<hov2>lazy@ %a@]" self#simple_expr e
-    (* Pexp_poly: impossible but we should print it anyway, rather
-       than assert false *)
+        pp f "@[<hov2>lazy@ %a@]" (simple_expr ctxt) e
+    (* Pexp_poly: impossible but we should print it anyway, rather than
+       assert false *)
     | Pexp_poly (e, None) ->
-        pp f "@[<hov2>!poly!@ %a@]" self#simple_expr e
+        pp f "@[<hov2>!poly!@ %a@]" (simple_expr ctxt) e
     | Pexp_poly (e, Some ct) ->
-        pp f "@[<hov2>(!poly!@ %a@ : %a)@]" self#simple_expr e self#core_type ct
+        pp f "@[<hov2>(!poly!@ %a@ : %a)@]"
+          (simple_expr ctxt) e (core_type ctxt) ct
     | Pexp_open (ovf, lid, e) ->
-        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) self#longident_loc lid
-          self#expression  e
+        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
+          (expression ctxt) e
     | Pexp_variant (l,Some eo) ->
-        pp f "@[<2>`%s@;%a@]" l  self#simple_expr eo
-    | Pexp_extension e -> self#extension f e
-    | Pexp_unreachable ->
-        pp f "."
-    | _ -> self#expression1 f x
-  method expression1 f x =
-    if x.pexp_attributes <> [] then self#expression f x
-    else match x.pexp_desc with
-    | Pexp_object cs -> pp f "%a" self#class_structure cs
-    | _ -> self#expression2 f x
-  (* used in [Pexp_apply] *)
-  method expression2 f x =
-    if x.pexp_attributes <> [] then self#expression f x
-    else match x.pexp_desc with
+        pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo
+    | Pexp_extension e -> extension ctxt f e
+    | Pexp_unreachable -> pp f "."
+    | _ -> expression1 ctxt f x
+
+and expression1 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
+    | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs
+    | _ -> expression2 ctxt f x
+(* used in [Pexp_apply] *)
+
+and expression2 ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
     | Pexp_field (e, li) ->
-        pp f "@[<hov2>%a.%a@]" self#simple_expr e self#longident_loc li
-    | Pexp_send (e, s) ->  pp f "@[<hov2>%a#%s@]" self#simple_expr e  s
+        pp f "@[<hov2>%a.%a@]" (simple_expr ctxt) e longident_loc li
+    | Pexp_send (e, s) -> pp f "@[<hov2>%a#%s@]" (simple_expr ctxt) e s
 
-    | _ -> self#simple_expr f x
-  method simple_expr f x =
-    if x.pexp_attributes <> [] then self#expression f x
-    else match x.pexp_desc with
+    | _ -> simple_expr ctxt f x
+
+and simple_expr ctxt f x =
+  if x.pexp_attributes <> [] then expression ctxt f x
+  else match x.pexp_desc with
     | Pexp_construct _  when is_simple_construct (view_expr x) ->
         (match view_expr x with
-        | `nil -> pp f "[]"
-        | `tuple -> pp f "()"
-        | `list xs ->
-            pp f "@[<hv0>[%a]@]"
-               (self#list self#under_semi#expression ~sep:";@;") xs
-        | `simple x -> self#longident f x
-        | _ -> assert false)
+         | `nil -> pp f "[]"
+         | `tuple -> pp f "()"
+         | `list xs ->
+             pp f "@[<hv0>[%a]@]"
+               (list (expression (under_semi ctxt)) ~sep:";@;") xs
+         | `simple x -> longident f x
+         | _ -> assert false)
     | Pexp_ident li ->
-        self#longident_loc f li
-        (* (match view_fixity_of_exp x with *)
-        (* |`Normal -> self#longident_loc f li *)
-        (* | `Prefix _ | `Infix _ -> pp f "( %a )" self#longident_loc li) *)
-    | Pexp_constant c -> self#constant f c;
+        longident_loc f li
+    (* (match view_fixity_of_exp x with *)
+    (* |`Normal -> longident_loc f li *)
+    (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *)
+    | Pexp_constant c -> constant f c;
     | Pexp_pack me ->
-        pp f "(module@;%a)"  self#module_expr me
+        pp f "(module@;%a)" (module_expr ctxt) me
     | Pexp_newtype (lid, e) ->
-        pp f "fun@;(type@;%s)@;->@;%a"  lid  self#expression  e
+        pp f "fun@;(type@;%s)@;->@;%a" lid (expression ctxt) e
     | Pexp_tuple l ->
-        pp f "@[<hov2>(%a)@]"  (self#list self#simple_expr  ~sep:",@;")  l
+        pp f "@[<hov2>(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l
     | Pexp_constraint (e, ct) ->
-        pp f "(%a : %a)" self#expression e self#core_type ct
+        pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct
     | Pexp_coerce (e, cto1, ct) ->
-        pp f "(%a%a :> %a)" self#expression e
-          (self#option self#core_type ~first:" : " ~last:" ")
-          cto1 (* no sep hint*)
-          self#core_type ct
+        pp f "(%a%a :> %a)" (expression ctxt) e
+          (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*)
+          (core_type ctxt) ct
     | Pexp_variant (l, None) -> pp f "`%s" l
     | Pexp_record (l, eo) ->
         let longident_x_expression f ( li, e) =
           match e.pexp_desc with
           |  Pexp_ident {txt;_} when li.txt = txt ->
-              pp f "@[<hov2>%a@]" self#longident_loc li
+              pp f "@[<hov2>%a@]" longident_loc li
           | _ ->
-              pp f "@[<hov2>%a@;=@;%a@]" self#longident_loc li self#simple_expr
-                 e
+              pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
         in
         pp f "@[<hv0>@[<hv2>{@;%a%a@]@;}@]"(* "@[<hov2>{%a%a}@]" *)
-          (self#option ~last:" with@;" self#simple_expr) eo
-          (self#list longident_x_expression ~sep:";@;")  l
+          (option ~last:" with@;" (simple_expr ctxt)) eo
+          (list longident_x_expression ~sep:";@;") l
     | Pexp_array (l) ->
         pp f "@[<0>@[<2>[|%a|]@]@]"
-          (self#list self#under_semi#simple_expr ~sep:";") l
+          (list (simple_expr (under_semi ctxt)) ~sep:";") l
     | Pexp_while (e1, e2) ->
-        let fmt:(_,_,_)format = "@[<2>while@;%a@;do@;%a@;done@]" in
-        pp f fmt self#expression e1 self#expression e2
+        let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in
+        pp f fmt (expression ctxt) e1 (expression ctxt) e2
     | Pexp_for (s, e1, e2, df, e3) ->
         let fmt:(_,_,_)format =
           "@[<hv0>@[<hv2>@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in
-        pp f fmt self#pattern s self#expression e1 self#direction_flag df
-           self#expression e2  self#expression e3
-    | _ ->  self#paren true self#expression f x
-
-  method attributes f l =
-    List.iter (self # attribute f) l
-
-  method item_attributes f l =
-    List.iter (self # item_attribute f) l
-
-  method attribute f (s, e) =
-    pp f "@[<2>[@@%s@ %a]@]" s.txt self#payload e
-
-  method item_attribute f (s, e) =
-    pp f "@[<2>[@@@@%s@ %a]@]" s.txt self#payload e
-
-  method floating_attribute f (s, e) =
-    pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt self#payload e
-
-  method value_description f x =
-    (* note: value_description has an attribute field,
-       but they're already printed by the callers this method *)
-    pp f "@[<hov2>%a%a@]" self#core_type x.pval_type
-      (fun f x ->
-        if x.pval_prim<>[] then begin
-          pp f "@ =@ %a"
-            (self#list self#constant_string)
-            x.pval_prim ;
-        end) x
-
-  method extension f (s, e) =
-    pp f "@[<2>[%%%s@ %a]@]" s.txt self#payload e
-
-  method item_extension f (s, e) =
-    pp f "@[<2>[%%%%%s@ %a]@]" s.txt self#payload e
-
-  method exception_declaration f ext =
-    pp f "@[<hov2>exception@ %a@]" self#extension_constructor ext
-
-  method class_signature f { pcsig_self = ct; pcsig_fields = l ;_} =
-    let class_type_field f x =
-      match x.pctf_desc with
-      | Pctf_inherit (ct) ->
-          pp f "@[<2>inherit@ %a@]%a" self#class_type ct
-            self#item_attributes x.pctf_attributes
-      | Pctf_val (s, mf, vf, ct) ->
-          pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
-            self#mutable_flag mf self#virtual_flag vf s  self#core_type  ct
-            self#item_attributes x.pctf_attributes
-      | Pctf_method (s, pf, vf, ct) ->
-          pp f "@[<2>method %a %a%s :@;%a@]%a"
-            self#private_flag pf self#virtual_flag vf s self#core_type ct
-            self#item_attributes x.pctf_attributes
-      | Pctf_constraint (ct1, ct2) ->
-          pp f "@[<2>constraint@ %a@ =@ %a@]%a"
-            self#core_type ct1 self#core_type ct2
-            self#item_attributes x.pctf_attributes
-      | Pctf_attribute a -> self#floating_attribute f a
-      | Pctf_extension e ->
-          self#item_extension f e;
-          self#item_attributes f x.pctf_attributes
-    in
-    pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
-      (fun f ct -> match ct.ptyp_desc with
-      | Ptyp_any -> ()
-      | _ -> pp f " (%a)" self#core_type ct) ct
-      (self#list   class_type_field ~sep:"@;") l  ;
-
-  (* call [class_signature] called by [class_signature] *)
-  method class_type f x =
-    match x.pcty_desc with
-    | Pcty_signature cs ->
-        self#class_signature f cs;
-        self#attributes f x.pcty_attributes
-    | Pcty_constr (li, l) ->
-        pp f "%a%a%a"
-          (fun f l -> match l with
-          | [] -> ()
-          | _  -> pp f "[%a]@ " (self#list self#core_type ~sep:"," ) l) l
-          self#longident_loc li
-          self#attributes x.pcty_attributes
-    | Pcty_arrow (l, co, cl) ->
-        pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
-          self#type_with_label (l,co)
-          self#class_type cl
-    | Pcty_extension e ->
-        self#extension f e;
-        self#attributes f x.pcty_attributes
-
-  (* [class type a = object end] *)
-  method class_type_declaration_list f  l =
-    let class_type_declaration kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
-      pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
-        self#virtual_flag x.pci_virt
-        self#class_params_def ls txt
-        self#class_type x.pci_expr
-        self#item_attributes x.pci_attributes
-    in
-    match l with
-    | [] -> ()
-    | [x] -> class_type_declaration "class type" f x
-    | x :: xs ->
-        pp f "@[<v>%a@,%a@]"
-          (class_type_declaration "class type") x
-          (self#list ~sep:"@," (class_type_declaration "and")) xs
-
-  method class_field f x =
-    match x.pcf_desc with
-    | Pcf_inherit (ovf, ce, so) ->
-        pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
-          self#class_expr ce
-          (fun f so -> match so with
-          | None -> ();
-          | Some (s) -> pp f "@ as %s" s ) so
-          self#item_attributes x.pcf_attributes
-    | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
-        pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
-          self#mutable_flag mf s.txt
-          self#expression  e
-          self#item_attributes x.pcf_attributes
-    | Pcf_method (s, pf, Cfk_virtual ct) ->
-        pp f "@[<2>method virtual %a %s :@;%a@]%a"
-          self#private_flag pf s.txt
-          self#core_type  ct
-          self#item_attributes x.pcf_attributes
-    | Pcf_val (s, mf, Cfk_virtual ct) ->
-        pp f "@[<2>val virtual %a%s :@ %a@]%a"
-          self#mutable_flag mf s.txt
-          self#core_type  ct
-          self#item_attributes x.pcf_attributes
-    | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
-        let bind e =
-          self#binding f
-            {pvb_pat=
-               {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
-             pvb_expr=e;
-             pvb_attributes=[];
-             pvb_loc=Location.none;
-            }
-        in
-        pp f "@[<2>method%s %a%a@]%a"
-          (override ovf)
-          self#private_flag pf
-          (fun f e -> match e.pexp_desc with
-          | Pexp_poly (e, Some ct) ->
-              pp f "%s :@;%a=@;%a"
-                s.txt (self#core_type) ct self#expression e
-          | Pexp_poly (e,None) -> bind e
-          | _ -> bind e) e
-          self#item_attributes x.pcf_attributes
-    | Pcf_constraint (ct1, ct2) ->
-        pp f "@[<2>constraint %a =@;%a@]%a"
-          self#core_type ct1
-          self#core_type ct2
-          self#item_attributes x.pcf_attributes
-    | Pcf_initializer (e) ->
-        pp f "@[<2>initializer@ %a@]%a"
-          self#expression e
-          self#item_attributes x.pcf_attributes
-    | Pcf_attribute a -> self#floating_attribute f a
-    | Pcf_extension e ->
-        self#item_extension f e;
-        self#item_attributes f x.pcf_attributes
-
-  method class_structure f { pcstr_self = p; pcstr_fields =  l } =
-    pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
-      (fun f p -> match p.ppat_desc with
-      | Ppat_any -> ()
-      | Ppat_constraint _ -> pp f " %a"  self#pattern  p
-      | _ -> pp f " (%a)" self#pattern p) p
-      (self#list self#class_field ) l
-
-  method class_expr f x =
-    if x.pcl_attributes <> [] then begin
-      pp f "((%a)%a)" self#class_expr {x with pcl_attributes=[]}
-        self#attributes x.pcl_attributes
-    end else
+        let expression = expression ctxt in
+        pp f fmt (pattern ctxt) s expression e1 direction_flag
+          df expression e2 expression e3
+    | _ ->  paren true (expression ctxt) f x
+
+and attributes ctxt f l =
+  List.iter (attribute ctxt f) l
+
+and item_attributes ctxt f l =
+  List.iter (item_attribute ctxt f) l
+
+and attribute ctxt f (s, e) =
+  pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_attribute ctxt f (s, e) =
+  pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and floating_attribute ctxt f (s, e) =
+  pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e
+
+and value_description ctxt f x =
+  (* note: value_description has an attribute field,
+           but they're already printed by the callers this method *)
+  pp f "@[<hov2>%a%a@]" (core_type ctxt) x.pval_type
+    (fun f x ->
+       if x.pval_prim <> []
+       then pp f "@ =@ %a" (list constant_string) x.pval_prim
+    ) x
+
+and extension ctxt f (s, e) =
+  pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and item_extension ctxt f (s, e) =
+  pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e
+
+and exception_declaration ctxt f ext =
+  pp f "@[<hov2>exception@ %a@]" (extension_constructor ctxt) ext
+
+and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
+  let class_type_field f x =
+    match x.pctf_desc with
+    | Pctf_inherit (ct) ->
+        pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_val (s, mf, vf, ct) ->
+        pp f "@[<2>val @ %a%a%s@ :@ %a@]%a"
+          mutable_flag mf virtual_flag vf s (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_method (s, pf, vf, ct) ->
+        pp f "@[<2>method %a %a%s :@;%a@]%a"
+          private_flag pf virtual_flag vf s (core_type ctxt) ct
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_constraint (ct1, ct2) ->
+        pp f "@[<2>constraint@ %a@ =@ %a@]%a"
+          (core_type ctxt) ct1 (core_type ctxt) ct2
+          (item_attributes ctxt) x.pctf_attributes
+    | Pctf_attribute a -> floating_attribute ctxt f a
+    | Pctf_extension e ->
+        item_extension ctxt f e;
+        item_attributes ctxt f x.pctf_attributes
+  in
+  pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
+    (fun f ct -> match ct.ptyp_desc with
+       | Ptyp_any -> ()
+       | _ -> pp f " (%a)" (core_type ctxt) ct) ct
+    (list class_type_field ~sep:"@;") l
+
+(* call [class_signature] called by [class_signature] *)
+and class_type ctxt f x =
+  match x.pcty_desc with
+  | Pcty_signature cs ->
+      class_signature ctxt f cs;
+      attributes ctxt f x.pcty_attributes
+  | Pcty_constr (li, l) ->
+      pp f "%a%a%a"
+        (fun f l -> match l with
+           | [] -> ()
+           | _  -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l
+        longident_loc li
+        (attributes ctxt) x.pcty_attributes
+  | Pcty_arrow (l, co, cl) ->
+      pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
+        (type_with_label ctxt) (l,co)
+        (class_type ctxt) cl
+  | Pcty_extension e ->
+      extension ctxt f e;
+      attributes ctxt f x.pcty_attributes
+
+(* [class type a = object end] *)
+and class_type_declaration_list ctxt f l =
+  let class_type_declaration kwd f x =
+    let { pci_params=ls; pci_name={ txt; _ }; _ } = x in
+    pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd
+      virtual_flag x.pci_virt
+      (class_params_def ctxt) ls txt
+      (class_type ctxt) x.pci_expr
+      (item_attributes ctxt) x.pci_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> class_type_declaration "class type" f x
+  | x :: xs ->
+      pp f "@[<v>%a@,%a@]"
+        (class_type_declaration "class type") x
+        (list ~sep:"@," (class_type_declaration "and")) xs
+
+and class_field ctxt f x =
+  match x.pcf_desc with
+  | Pcf_inherit (ovf, ce, so) ->
+      pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf)
+        (class_expr ctxt) ce
+        (fun f so -> match so with
+           | None -> ();
+           | Some (s) -> pp f "@ as %s" s ) so
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_concrete (ovf, e)) ->
+      pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf)
+        mutable_flag mf s.txt
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_virtual ct) ->
+      pp f "@[<2>method virtual %a %s :@;%a@]%a"
+        private_flag pf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_val (s, mf, Cfk_virtual ct) ->
+      pp f "@[<2>val virtual %a%s :@ %a@]%a"
+        mutable_flag mf s.txt
+        (core_type ctxt) ct
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_method (s, pf, Cfk_concrete (ovf, e)) ->
+      let bind e =
+        binding ctxt f
+          {pvb_pat=
+             {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]};
+           pvb_expr=e;
+           pvb_attributes=[];
+           pvb_loc=Location.none;
+          }
+      in
+      pp f "@[<2>method%s %a%a@]%a"
+        (override ovf)
+        private_flag pf
+        (fun f e -> match e.pexp_desc with
+           | Pexp_poly (e, Some ct) ->
+               pp f "%s :@;%a=@;%a"
+                 s.txt (core_type ctxt) ct (expression ctxt) e
+           | Pexp_poly (e,None) -> bind e
+           | _ -> bind e) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_constraint (ct1, ct2) ->
+      pp f "@[<2>constraint %a =@;%a@]%a"
+        (core_type ctxt) ct1
+        (core_type ctxt) ct2
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_initializer (e) ->
+      pp f "@[<2>initializer@ %a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) x.pcf_attributes
+  | Pcf_attribute a -> floating_attribute ctxt f a
+  | Pcf_extension e ->
+      item_extension ctxt f e;
+      item_attributes ctxt f x.pcf_attributes
+
+and class_structure ctxt f { pcstr_self = p; pcstr_fields =  l } =
+  pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]"
+    (fun f p -> match p.ppat_desc with
+       | Ppat_any -> ()
+       | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p
+       | _ -> pp f " (%a)" (pattern ctxt) p) p
+    (list (class_field ctxt)) l
+
+and class_expr ctxt f x =
+  if x.pcl_attributes <> [] then begin
+    pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]}
+      (attributes ctxt) x.pcl_attributes
+  end else
     match x.pcl_desc with
-    | Pcl_structure (cs) -> self#class_structure f cs
+    | Pcl_structure (cs) -> class_structure ctxt f cs
     | Pcl_fun (l, eo, p, e) ->
         pp f "fun@ %a@ ->@ %a"
-          self#label_exp (l,eo,p)
-          self#class_expr e
+          (label_exp ctxt) (l,eo,p)
+          (class_expr ctxt) e
     | Pcl_let (rf, l, ce) ->
         pp f "%a@ in@ %a"
-          self#bindings  (rf,l)
-          self#class_expr ce
+          (bindings ctxt) (rf,l)
+          (class_expr ctxt) ce
     | Pcl_apply (ce, l) ->
-        pp f "(%a@ %a)"
-          self#class_expr ce
-          (self#list self#label_x_expression_param) l
+        pp f "((%a)@ %a)" (* Cf: #7200 *)
+          (class_expr ctxt) ce
+          (list (label_x_expression_param ctxt)) l
     | Pcl_constr (li, l) ->
         pp f "%a%a"
           (fun f l-> if l <>[] then
-            pp f "[%a]@ "
-              (self#list self#core_type  ~sep:"," ) l ) l
-          self#longident_loc li
+              pp f "[%a]@ "
+                (list (core_type ctxt) ~sep:",") l) l
+          longident_loc li
     | Pcl_constraint (ce, ct) ->
         pp f "(%a@ :@ %a)"
-          self#class_expr ce
-          self#class_type ct
-    | Pcl_extension e -> self#extension f e
-
-  method module_type f x =
-    if x.pmty_attributes <> [] then begin
-      pp f "((%a)%a)" self#module_type {x with pmty_attributes=[]}
-        self#attributes x.pmty_attributes
-    end else
+          (class_expr ctxt) ce
+          (class_type ctxt) ct
+    | Pcl_extension e -> extension ctxt f e
+
+and module_type ctxt f x =
+  if x.pmty_attributes <> [] then begin
+    pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]}
+      (attributes ctxt) x.pmty_attributes
+  end else
     match x.pmty_desc with
     | Pmty_ident li ->
-        pp f "%a" self#longident_loc li;
+        pp f "%a" longident_loc li;
     | Pmty_alias li ->
-        pp f "(module %a)" self#longident_loc li;
+        pp f "(module %a)" longident_loc li;
     | Pmty_signature (s) ->
         pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
-          (self#list self#signature_item  ) s (* FIXME wrong indentation*)
+          (list (signature_item ctxt)) s (* FIXME wrong indentation*)
     | Pmty_functor (_, None, mt2) ->
-        pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2
+        pp f "@[<hov2>functor () ->@ %a@]" (module_type ctxt) mt2
     | Pmty_functor (s, Some mt1, mt2) ->
         if s.txt = "_" then
           pp f "@[<hov2>%a@ ->@ %a@]"
-             self#module_type mt1  self#module_type mt2
+            (module_type ctxt) mt1 (module_type ctxt) mt2
         else
           pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
-             self#module_type mt1  self#module_type mt2
+            (module_type ctxt) mt1 (module_type ctxt) mt2
     | Pmty_with (mt, l) ->
         let with_constraint f = function
           | Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
               let ls = List.map fst ls in
               pp f "type@ %a %a =@ %a"
-                (self#list self#core_type ~sep:"," ~first:"(" ~last:")")
-                ls self#longident_loc li  self#type_declaration td
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
+                ls longident_loc li (type_declaration ctxt) td
           | Pwith_module (li, li2) ->
-              pp f "module %a =@ %a" self#longident_loc li self#longident_loc
-                 li2;
+              pp f "module %a =@ %a" longident_loc li longident_loc li2;
           | Pwith_typesubst ({ptype_params=ls;_} as td) ->
               let ls = List.map fst ls in
               pp f "type@ %a %s :=@ %a"
-                (self#list self#core_type ~sep:"," ~first:"(" ~last:")")
+                (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
                 ls td.ptype_name.txt
-                self#type_declaration  td
+                (type_declaration ctxt) td
           | Pwith_modsubst (s, li2) ->
-              pp f "module %s :=@ %a" s.txt self#longident_loc li2 in
+              pp f "module %s :=@ %a" s.txt longident_loc li2 in
         (match l with
-        | [] -> pp f "@[<hov2>%a@]" self#module_type mt
-        | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
-              self#module_type mt (self#list with_constraint ~sep:"@ and@ ") l )
+         | [] -> pp f "@[<hov2>%a@]" (module_type ctxt) mt
+         | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
+                  (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l)
     | Pmty_typeof me ->
-        pp f "@[<hov2>module@ type@ of@ %a@]"
-          self#module_expr me
-    | Pmty_extension e -> self#extension f e
-
-  method signature f x =  self#list ~sep:"@\n" self#signature_item f x
-
-  method signature_item f x :unit= begin
-    match x.psig_desc with
-    | Psig_type (rf, l) ->
-        self#type_def_list f (rf, l)
-    | Psig_value vd ->
-        let intro = if vd.pval_prim = [] then "val" else "external" in
-          pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
-             protect_ident vd.pval_name.txt
-             self#value_description vd
-             self#item_attributes vd.pval_attributes
-    | Psig_typext te ->
-        self#type_extension f te
-    | Psig_exception ed ->
-        self#exception_declaration f ed
-    | Psig_class l ->
-        let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
-          pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
-            self#virtual_flag x.pci_virt
-            self#class_params_def ls txt
-            self#class_type x.pci_expr
-            self#item_attributes x.pci_attributes
-        in begin
-          match l with
-          | [] -> ()
-          | [x] -> class_description "class" f x
-          | x :: xs ->
-              pp f "@[<v>%a@,%a@]"
-                 (class_description "class") x
-                 (self#list ~sep:"@," (class_description "and")) xs
-        end
-    | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias};_} as pmd) ->
-        pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
-          self#longident_loc alias
-          self#item_attributes pmd.pmd_attributes
-    | Psig_module pmd ->
-        pp f "@[<hov>module@ %s@ :@ %a@]%a"
-          pmd.pmd_name.txt
-          self#module_type pmd.pmd_type
-          self#item_attributes pmd.pmd_attributes
-    | Psig_open od ->
-        pp f "@[<hov2>open%s@ %a@]%a"
-           (override od.popen_override)
-           self#longident_loc od.popen_lid
-           self#item_attributes od.popen_attributes
-    | Psig_include incl ->
-        pp f "@[<hov2>include@ %a@]%a"
-          self#module_type incl.pincl_mod
-          self#item_attributes incl.pincl_attributes
-    | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
-        pp f "@[<hov2>module@ type@ %s%a@]%a"
-          s.txt
-          (fun f md -> match md with
-          | None -> ()
-          | Some mt ->
-              pp_print_space f () ;
-              pp f "@ =@ %a"  self#module_type mt
-          ) md
-          self#item_attributes attrs
-    | Psig_class_type (l) ->
-        self#class_type_declaration_list f l ;
-    | Psig_recmodule decls ->
-        let rec  string_x_module_type_list f ?(first=true) l =
-          match l with
-          | [] -> () ;
-          | pmd :: tl ->
-              if not first then
-                pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
-                  self#module_type pmd.pmd_type
-                  self#item_attributes pmd.pmd_attributes
-              else
-                pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
-                  self#module_type pmd.pmd_type
-                  self#item_attributes pmd.pmd_attributes;
-              string_x_module_type_list f ~first:false tl
-        in
-          string_x_module_type_list f decls
-    | Psig_attribute a -> self#floating_attribute f a
-    | Psig_extension(e, a) ->
-        self#item_extension f e;
-        self#item_attributes f a
-  end
-  method module_expr f x =
-    if x.pmod_attributes <> [] then begin
-      pp f "((%a)%a)" self#module_expr {x with pmod_attributes=[]}
-        self#attributes x.pmod_attributes
-    end else
-    match x.pmod_desc with
+        pp f "@[<hov2>module@ type@ of@ %a@]" (module_expr ctxt) me
+    | Pmty_extension e -> extension ctxt f e
+
+and signature ctxt f x =  list ~sep:"@\n" (signature_item ctxt) f x
+
+and signature_item ctxt f x : unit =
+  match x.psig_desc with
+  | Psig_type (rf, l) ->
+      type_def_list ctxt f (rf, l)
+  | Psig_value vd ->
+      let intro = if vd.pval_prim = [] then "val" else "external" in
+      pp f "@[<2>%s@ %a@ :@ %a@]%a" intro
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Psig_typext te ->
+      type_extension ctxt f te
+  | Psig_exception ed ->
+      exception_declaration ctxt f ed
+  | Psig_class l ->
+      let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) =
+        pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (class_type ctxt) x.pci_expr
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_description "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_description "class") x
+              (list ~sep:"@," (class_description "and")) xs
+      end
+  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias};_} as pmd) ->
+      pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
+        longident_loc alias
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_module pmd ->
+      pp f "@[<hov>module@ %s@ :@ %a@]%a"
+        pmd.pmd_name.txt
+        (module_type ctxt) pmd.pmd_type
+        (item_attributes ctxt) pmd.pmd_attributes
+  | Psig_open od ->
+      pp f "@[<hov2>open%s@ %a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_lid
+        (item_attributes ctxt) od.popen_attributes
+  | Psig_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_type ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Psig_class_type (l) -> class_type_declaration_list ctxt f l
+  | Psig_recmodule decls ->
+      let rec  string_x_module_type_list f ?(first=true) l =
+        match l with
+        | [] -> () ;
+        | pmd :: tl ->
+            if not first then
+              pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt
+                (module_type ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes
+            else
+              pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt
+                (module_type ctxt) pmd.pmd_type
+                (item_attributes ctxt) pmd.pmd_attributes;
+            string_x_module_type_list f ~first:false tl
+      in
+      string_x_module_type_list f decls
+  | Psig_attribute a -> floating_attribute ctxt f a
+  | Psig_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and module_expr ctxt f x =
+  if x.pmod_attributes <> [] then
+    pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]}
+      (attributes ctxt) x.pmod_attributes
+  else match x.pmod_desc with
     | Pmod_structure (s) ->
         pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]"
-          (self#list self#structure_item  ~sep:"@\n") s;
+          (list (structure_item ctxt) ~sep:"@\n") s;
     | Pmod_constraint (me, mt) ->
         pp f "@[<hov2>(%a@ :@ %a)@]"
-          self#module_expr  me
-          self#module_type mt
+          (module_expr ctxt) me
+          (module_type ctxt) mt
     | Pmod_ident (li) ->
-        pp f "%a" self#longident_loc li;
+        pp f "%a" longident_loc li;
     | Pmod_functor (_, None, me) ->
-        pp f "functor ()@;->@;%a" self#module_expr me
+        pp f "functor ()@;->@;%a" (module_expr ctxt) me
     | Pmod_functor (s, Some mt, me) ->
         pp f "functor@ (%s@ :@ %a)@;->@;%a"
-          s.txt  self#module_type mt  self#module_expr me
+          s.txt (module_type ctxt) mt (module_expr ctxt) me
     | Pmod_apply (me1, me2) ->
-        pp f "%a(%a)" self#module_expr me1  self#module_expr  me2
+        pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2
+        (* Cf: #7200 *)
     | Pmod_unpack e ->
-        pp f "(val@ %a)"  self#expression  e
-    | Pmod_extension e -> self#extension f e
-
-  method structure f x = self#list ~sep:"@\n" self#structure_item f x
-
-  method payload f = function
-    | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
-        pp f "@[<2>%a@]%a"
-          self#expression e
-          self#item_attributes attrs
-    | PStr x -> self#structure f x
-    | PTyp x -> pp f ":"; self#core_type f x
-    | PSig x -> pp f ":"; self#signature f x
-    | PPat (x, None) -> pp f "?"; self#pattern f x
-    | PPat (x, Some e) ->
-      pp f "?"; self#pattern f x;
-      pp f " when "; self#expression f e
-
-  (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
-  method binding f {pvb_pat=p; pvb_expr=x; _} =
-    (* .pvb_attributes have already been printed by the caller, #bindings *)
-    let rec pp_print_pexp_function f x =
-      if x.pexp_attributes <> [] then pp f "=@;%a" self#expression x
-      else match x.pexp_desc with
+        pp f "(val@ %a)" (expression ctxt) e
+    | Pmod_extension e -> extension ctxt f e
+
+and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x
+
+and payload ctxt f = function
+  | PStr [{pstr_desc = Pstr_eval (e, attrs)}] ->
+      pp f "@[<2>%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | PStr x -> structure ctxt f x
+  | PTyp x -> pp f ":"; core_type ctxt f x
+  | PSig x -> pp f ":"; signature ctxt f x
+  | PPat (x, None) -> pp f "?"; pattern ctxt f x
+  | PPat (x, Some e) ->
+      pp f "?"; pattern ctxt f x;
+      pp f " when "; expression ctxt f e
+
+(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *)
+and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
+  (* .pvb_attributes have already been printed by the caller, #bindings *)
+  let rec pp_print_pexp_function f x =
+    if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x
+    else match x.pexp_desc with
       | Pexp_fun (label, eo, p, e) ->
           if label=Nolabel then
-            pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function e
+            pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e
           else
-            pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e
+            pp f "%a@ %a"
+              (label_exp ctxt) (label,eo,p) pp_print_pexp_function e
       | Pexp_newtype (str,e) ->
           pp f "(type@ %s)@ %a" str pp_print_pexp_function e
-      | _ -> pp f "=@;%a" self#expression x in
-    if x.pexp_attributes <> [] then
-      pp f "%a@;=@;%a" self#pattern p self#expression x
-    else match (x.pexp_desc,p.ppat_desc) with
+      | _ -> pp f "=@;%a" (expression ctxt) x
+  in
+  if x.pexp_attributes <> []
+  then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+  else match (x.pexp_desc,p.ppat_desc) with
     | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
-        (match ty.ptyp_desc with
+        begin match ty.ptyp_desc with
         | Ptyp_poly _ ->
-            pp f "%a@;:@;%a@;=@;%a" self#simple_pattern p
-              self#core_type ty self#expression x
+            pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
+              (core_type ctxt) ty (expression ctxt) x
         | _ ->
-            pp f "(%a@;:@;%a)@;=@;%a" self#simple_pattern p
-              self#core_type ty self#expression x)
+            pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
+              (core_type ctxt) ty (expression ctxt) x
+        end
     | Pexp_constraint (e,t1),Ppat_var {txt;_} ->
-        pp f "%a@;:@ %a@;=@;%a" protect_ident txt self#core_type t1
-           self#expression e
+      pp f "%a@;:@ %a@;=@;%a" protect_ident txt
+        (core_type ctxt) t1 (expression ctxt) e
     | (_, Ppat_var _) ->
-        pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function x
+        pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
     | _ ->
-        pp f "%a@;=@;%a" self#pattern p self#expression x
-  (* [in] is not printed *)
-  method bindings f (rf,l) =
-    let binding kwd rf f x =
-      pp f "@[<2>%s %a%a@]@ %a" kwd self#rec_flag rf
-         self#binding x self#item_attributes x.pvb_attributes
-    in
-    begin match l with
-    | [] -> ()
-    | [x] -> binding "let" rf f x
-    | x::xs ->
-        pp f "@[<v>%a@,%a@]"
-          (binding "let" rf) x
-          (self#list ~sep:"@," (binding "and" Nonrecursive)) xs
-    end
-
-  method structure_item f x = begin
-    match x.pstr_desc with
-    | Pstr_eval (e, attrs) ->
-        pp f "@[<hov2>;;%a@]%a"
-          self#expression e
-          self#item_attributes attrs
-    | Pstr_type (_, []) -> assert false
-    | Pstr_type (rf, l)  -> self#type_def_list f (rf, l)
-    | Pstr_value (rf, l) ->
-        (* pp f "@[<hov2>let %a%a@]"  self#rec_flag rf self#bindings l *)
-        pp f "@[<2>%a@]" self#bindings (rf,l)
-    | Pstr_typext te -> self#type_extension f te
-    | Pstr_exception ed -> self#exception_declaration f ed
-    | Pstr_module x ->
-        let rec module_helper me =
-          match me.pmod_desc with
-          | Pmod_functor(s,mt,me') when me.pmod_attributes = [] ->
-              if mt = None then pp f "()"
-              else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt;
-              module_helper me'
-          | _ -> me
-        in
-        pp f "@[<hov2>module %s%a@]%a"
-          x.pmb_name.txt
-          (fun f me ->
-            let me = module_helper me in
-            (match me.pmod_desc with
-            | Pmod_constraint
-                (me',
-                 ({pmty_desc=(Pmty_ident (_)
-                             | Pmty_signature (_));_} as mt))
-              when me.pmod_attributes = [] ->
-                pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me'
-            | _ ->
-                pp f " =@ %a"  self#module_expr  me
-            )) x.pmb_expr
-          self#item_attributes x.pmb_attributes
-    | Pstr_open od ->
-        pp f "@[<2>open%s@;%a@]%a"
-           (override od.popen_override)
-           self#longident_loc od.popen_lid
-           self#item_attributes od.popen_attributes
-    | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
-        pp f "@[<hov2>module@ type@ %s%a@]%a"
-          s.txt
-          (fun f md -> match md with
-          | None -> ()
-          | Some mt ->
-              pp_print_space f () ;
-              pp f "@ =@ %a"  self#module_type mt
-          ) md
-          self#item_attributes attrs
-    | Pstr_class l ->
-        let extract_class_args cl =
-          let rec loop acc cl =
-            match cl.pcl_desc with
-            | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] ->
-                loop ((l,eo,p) :: acc) cl'
-            | _ -> List.rev acc, cl
-          in
-          let args, cl = loop [] cl in
-          let constr, cl =
-            match cl.pcl_desc with
-            | Pcl_constraint (cl', ct) when cl.pcl_attributes = [] ->
-                Some ct, cl'
-            | _ -> None, cl
-          in
-            args, constr, cl
+        pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
+
+(* [in] is not printed *)
+and bindings ctxt f (rf,l) =
+  let binding kwd rf f x =
+    pp f "@[<2>%s %a%a@]@ %a" kwd rec_flag rf
+      (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
+  in
+  match l with
+  | [] -> ()
+  | [x] -> binding "let" rf f x
+  | x::xs ->
+      pp f "@[<v>%a@,%a@]"
+        (binding "let" rf) x
+        (list ~sep:"@," (binding "and" Nonrecursive)) xs
+
+and structure_item ctxt f x =
+  match x.pstr_desc with
+  | Pstr_eval (e, attrs) ->
+      pp f "@[<hov2>;;%a@]%a"
+        (expression ctxt) e
+        (item_attributes ctxt) attrs
+  | Pstr_type (_, []) -> assert false
+  | Pstr_type (rf, l)  -> type_def_list ctxt f (rf, l)
+  | Pstr_value (rf, l) ->
+      (* pp f "@[<hov2>let %a%a@]"  rec_flag rf bindings l *)
+      pp f "@[<2>%a@]" (bindings ctxt) (rf,l)
+  | Pstr_typext te -> type_extension ctxt f te
+  | Pstr_exception ed -> exception_declaration ctxt f ed
+  | Pstr_module x ->
+      let rec module_helper me =
+        match me.pmod_desc with
+        | Pmod_functor(s,mt,me') when me.pmod_attributes = [] ->
+            if mt = None then pp f "()"
+            else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
+            module_helper me'
+        | _ -> me
+      in
+      pp f "@[<hov2>module %s%a@]%a"
+        x.pmb_name.txt
+        (fun f me ->
+           let me = module_helper me in
+           match me.pmod_desc with
+           | Pmod_constraint
+               (me',
+                ({pmty_desc=(Pmty_ident (_)
+                            | Pmty_signature (_));_} as mt))
+             when me.pmod_attributes = [] ->
+               pp f " :@;%a@;=@;%a@;"
+                 (module_type ctxt) mt (module_expr ctxt) me'
+           | _ -> pp f " =@ %a" (module_expr ctxt) me
+        ) x.pmb_expr
+        (item_attributes ctxt) x.pmb_attributes
+  | Pstr_open od ->
+      pp f "@[<2>open%s@;%a@]%a"
+        (override od.popen_override)
+        longident_loc od.popen_lid
+        (item_attributes ctxt) od.popen_attributes
+  | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} ->
+      pp f "@[<hov2>module@ type@ %s%a@]%a"
+        s.txt
+        (fun f md -> match md with
+           | None -> ()
+           | Some mt ->
+               pp_print_space f () ;
+               pp f "@ =@ %a" (module_type ctxt) mt
+        ) md
+        (item_attributes ctxt) attrs
+  | Pstr_class l ->
+      let extract_class_args cl =
+        let rec loop acc cl =
+          match cl.pcl_desc with
+          | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] ->
+              loop ((l,eo,p) :: acc) cl'
+          | _ -> List.rev acc, cl
         in
-        let class_constraint f ct = pp f ": @[%a@] " self#class_type ct in
-        let class_declaration kwd f
-            ({pci_params=ls; pci_name={txt;_}; _} as x) =
-          let args, constr, cl = extract_class_args x.pci_expr in
-          pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
-             self#virtual_flag x.pci_virt
-             self#class_params_def ls txt
-             (self#list self#label_exp) args
-             (self#option class_constraint) constr
-             self#class_expr cl
-             self#item_attributes x.pci_attributes
-        in begin
-          match l with
-          | [] -> ()
-          | [x] -> class_declaration "class" f x
-          | x :: xs ->
-              pp f "@[<v>%a@,%a@]"
-                 (class_declaration "class") x
-                 (self#list ~sep:"@," (class_declaration "and")) xs
-        end
-    | Pstr_class_type (l) ->
-        self#class_type_declaration_list f l ;
-    | Pstr_primitive vd ->
-        pp f "@[<hov2>external@ %a@ :@ %a@]%a"
-          protect_ident vd.pval_name.txt
-          self#value_description vd
-          self#item_attributes vd.pval_attributes
-    | Pstr_include incl ->
-        pp f "@[<hov2>include@ %a@]%a"
-          self#module_expr incl.pincl_mod
-          self#item_attributes incl.pincl_attributes
-    | Pstr_recmodule decls -> (* 3.07 *)
-        let aux f = function
-          | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
-              pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
-              self#module_type typ
-              self#module_expr expr
-              self#item_attributes pmb.pmb_attributes
-          | _ -> assert false
+        let args, cl = loop [] cl in
+        let constr, cl =
+          match cl.pcl_desc with
+          | Pcl_constraint (cl', ct) when cl.pcl_attributes = [] ->
+              Some ct, cl'
+          | _ -> None, cl
         in
-        begin match decls with
-        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
-            pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
-              pmb.pmb_name.txt
-              self#module_type typ
-              self#module_expr expr
-              self#item_attributes pmb.pmb_attributes
-              (fun f l2 -> List.iter (aux f) l2) l2
+        args, constr, cl
+      in
+      let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in
+      let class_declaration kwd f
+          ({pci_params=ls; pci_name={txt;_}; _} as x) =
+        let args, constr, cl = extract_class_args x.pci_expr in
+        pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd
+          virtual_flag x.pci_virt
+          (class_params_def ctxt) ls txt
+          (list (label_exp ctxt)) args
+          (option class_constraint) constr
+          (class_expr ctxt) cl
+          (item_attributes ctxt) x.pci_attributes
+      in begin
+        match l with
+        | [] -> ()
+        | [x] -> class_declaration "class" f x
+        | x :: xs ->
+            pp f "@[<v>%a@,%a@]"
+              (class_declaration "class") x
+              (list ~sep:"@," (class_declaration "and")) xs
+      end
+  | Pstr_class_type l -> class_type_declaration_list ctxt f l
+  | Pstr_primitive vd ->
+      pp f "@[<hov2>external@ %a@ :@ %a@]%a"
+        protect_ident vd.pval_name.txt
+        (value_description ctxt) vd
+        (item_attributes ctxt) vd.pval_attributes
+  | Pstr_include incl ->
+      pp f "@[<hov2>include@ %a@]%a"
+        (module_expr ctxt) incl.pincl_mod
+        (item_attributes ctxt) incl.pincl_attributes
+  | Pstr_recmodule decls -> (* 3.07 *)
+      let aux f = function
+        | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) ->
+            pp f "@[<hov2>@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt
+              (module_type ctxt) typ
+              (module_expr ctxt) expr
+              (item_attributes ctxt) pmb.pmb_attributes
         | _ -> assert false
-        end
-    | Pstr_attribute a -> self#floating_attribute f a
-    | Pstr_extension(e, a) ->
-        self#item_extension f e;
-        self#item_attributes f a
-  end
-  method type_param f (ct, a) =
-    pp f "%s%a" (type_variance a) self#core_type ct
-  method type_params f = function
-    [] -> ()
-  | l -> pp f "%a " (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l
-  method  type_def_list f (rf, l) =
-    let type_decl kwd rf f x =
-      let eq =
-        if (x.ptype_kind = Ptype_abstract)
-           && (x.ptype_manifest = None) then ""
-        else " ="
       in
-      pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
-        self#nonrec_flag rf
-        self#type_params x.ptype_params
-        x.ptype_name.txt eq
-        self#type_declaration x
-        self#item_attributes x.ptype_attributes
-    in
-    match l with
-    | [] -> assert false
-    | [x] -> type_decl "type" rf f x
-    | x :: xs -> pp f "@[<v>%a@,%a@]"
-          (type_decl "type" rf) x
-          (self#list ~sep:"@," (type_decl "and" Recursive)) xs
-
-  method record_declaration f lbls =
-    let type_record_field f pld =
-      pp f "@[<2>%a%s:@;%a@;%a@]"
-        self#mutable_flag pld.pld_mutable
-        pld.pld_name.txt
-        self#core_type pld.pld_type
-        self#attributes pld.pld_attributes
-    in
-    pp f "{@\n%a}"
-      (self#list type_record_field ~sep:";@\n" )  lbls
-
-  method type_declaration f x =
-    (* type_declaration has an attribute field,
-       but it's been printed by the caller of this method *)
-    let priv f =
-      match x.ptype_private with
-        Public -> ()
-      | Private -> pp f "@;private"
+      begin match decls with
+      | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 ->
+          pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]"
+            pmb.pmb_name.txt
+            (module_type ctxt) typ
+            (module_expr ctxt) expr
+            (item_attributes ctxt) pmb.pmb_attributes
+            (fun f l2 -> List.iter (aux f) l2) l2
+      | _ -> assert false
+      end
+  | Pstr_attribute a -> floating_attribute ctxt f a
+  | Pstr_extension(e, a) ->
+      item_extension ctxt f e;
+      item_attributes ctxt f a
+
+and type_param ctxt f (ct, a) =
+  pp f "%s%a" (type_variance a) (core_type ctxt) ct
+
+and type_params ctxt f = function
+  | [] -> ()
+  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l
+
+and type_def_list ctxt f (rf, l) =
+  let type_decl kwd rf f x =
+    let eq =
+      if (x.ptype_kind = Ptype_abstract)
+         && (x.ptype_manifest = None) then ""
+      else " ="
     in
-    let manifest f =
-      match x.ptype_manifest with
-      | None -> ()
-      | Some y ->
+    pp f "@[<2>%s %a%a%s%s%a@]%a" kwd
+      nonrec_flag rf
+      (type_params ctxt) x.ptype_params
+      x.ptype_name.txt eq
+      (type_declaration ctxt) x
+      (item_attributes ctxt) x.ptype_attributes
+  in
+  match l with
+  | [] -> assert false
+  | [x] -> type_decl "type" rf f x
+  | x :: xs -> pp f "@[<v>%a@,%a@]"
+                 (type_decl "type" rf) x
+                 (list ~sep:"@," (type_decl "and" Recursive)) xs
+
+and record_declaration ctxt f lbls =
+  let type_record_field f pld =
+    pp f "@[<2>%a%s:@;%a@;%a@]"
+      mutable_flag pld.pld_mutable
+      pld.pld_name.txt
+      (core_type ctxt) pld.pld_type
+      (attributes ctxt) pld.pld_attributes
+  in
+  pp f "{@\n%a}"
+    (list type_record_field ~sep:";@\n" )  lbls
+
+and type_declaration ctxt f x =
+  (* type_declaration has an attribute field,
+     but it's been printed by the caller of this method *)
+  let priv f =
+    match x.ptype_private with
+    | Public -> ()
+    | Private -> pp f "@;private"
+  in
+  let manifest f =
+    match x.ptype_manifest with
+    | None -> ()
+    | Some y ->
         if x.ptype_kind = Ptype_abstract then
-          pp f "%t@;%a" priv self#core_type y
+          pp f "%t@;%a" priv (core_type ctxt) y
         else
-          pp f "@;%a" self#core_type y
-    in
-    let constructor_declaration f pcd =
-      pp f "|@;";
-      self#constructor_declaration f (pcd.pcd_name.txt, pcd.pcd_args,
-                                      pcd.pcd_res, pcd.pcd_attributes)
-    in
-    let repr f =
-      let intro f =
-        if x.ptype_manifest = None then ()
-        else pp f "@;="
-      in
-      match x.ptype_kind with
-      | Ptype_variant xs ->
-          pp f "%t%t@\n%a" intro priv
-             (self#list ~sep:"@\n" constructor_declaration) xs
-      | Ptype_abstract -> ()
-      | Ptype_record l ->
-          pp f "%t%t@;%a" intro priv self#record_declaration l
-      | Ptype_open -> pp f "%t%t@;.." intro priv
-    in
-    let constraints f =
-      List.iter
-        (fun (ct1,ct2,_) ->
-           pp f "@[<hov2>@ constraint@ %a@ =@ %a@]"
-              self#core_type ct1 self#core_type ct2)
-        x.ptype_cstrs
+          pp f "@;%a" (core_type ctxt) y
+  in
+  let constructor_declaration f pcd =
+    pp f "|@;";
+    constructor_declaration ctxt f
+      (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes)
+  in
+  let repr f =
+    let intro f =
+      if x.ptype_manifest = None then ()
+      else pp f "@;="
     in
-      pp f "%t%t%t" manifest repr constraints
-
-  method type_extension f x =
-    let extension_constructor f x =
-      pp f "@\n|@;%a" self#extension_constructor x
-    in
-      pp f "@[<2>type %a%a +=%a@]%a"
-         (fun f -> function
-                | [] -> ()
-                | l ->  pp f "%a@;" (self#list self#type_param ~first:"("
-                                               ~last:")" ~sep:",")
-                                    l)
-         x.ptyext_params
-         self#longident_loc x.ptyext_path
-         (self#list ~sep:"" extension_constructor)
-         x.ptyext_constructors
-         self#item_attributes x.ptyext_attributes
-
-  method constructor_declaration f (name, args, res, attrs) =
-    match res with
-    | None ->
-        pp f "%s%a@;%a" name
-          (fun f -> function
-             | Pcstr_tuple [] -> ()
-             | Pcstr_tuple l ->
-                 pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l
-             | Pcstr_record l -> pp f "@;of@;%a" (self#record_declaration) l
-          ) args
-          self#attributes attrs
-    | Some r ->
-        pp f "%s:@;%a@;%a" name
-          (fun f -> function
-             | Pcstr_tuple [] -> self#core_type1 f r
-             | Pcstr_tuple l -> pp f "%a@;->@;%a"
-                                  (self#list self#core_type1 ~sep:"*@;") l
-                                  self#core_type1 r
-             | Pcstr_record l ->
-                 pp f "%a@;->@;%a" (self#record_declaration) l self#core_type1 r
-          )
-          args
-          self#attributes attrs
-
-
-  method extension_constructor f x =
-    match x.pext_kind with
-    | Pext_decl(l, r) ->
-        self#constructor_declaration f (x.pext_name.txt, l, r,
-                                        x.pext_attributes)
-    | Pext_rebind li ->
-        pp f "%s%a@;=@;%a" x.pext_name.txt
-          self#attributes x.pext_attributes
-          self#longident_loc li
-
-  method case_list f l : unit =
-    let aux f {pc_lhs; pc_guard; pc_rhs} =
-      pp f "@;| @[<2>%a%a@;->@;%a@]"
-        self#pattern pc_lhs (self#option self#expression ~first:"@;when@;")
-        pc_guard self#under_pipe#expression pc_rhs
-    in
-    self#list aux f l ~sep:""
-  method label_x_expression_param f (l,e) =
-    let simple_name = match e.pexp_desc with
+    match x.ptype_kind with
+    | Ptype_variant xs ->
+        pp f "%t%t@\n%a" intro priv
+          (list ~sep:"@\n" constructor_declaration) xs
+    | Ptype_abstract -> ()
+    | Ptype_record l ->
+        pp f "%t%t@;%a" intro priv (record_declaration ctxt) l
+    | Ptype_open -> pp f "%t%t@;.." intro priv
+  in
+  let constraints f =
+    List.iter
+      (fun (ct1,ct2,_) ->
+         pp f "@[<hov2>@ constraint@ %a@ =@ %a@]"
+           (core_type ctxt) ct1 (core_type ctxt) ct2)
+      x.ptype_cstrs
+  in
+  pp f "%t%t%t" manifest repr constraints
+
+and type_extension ctxt f x =
+  let extension_constructor f x =
+    pp f "@\n|@;%a" (extension_constructor ctxt) x
+  in
+  pp f "@[<2>type %a%a += %a@ %a@]%a"
+    (fun f -> function
+       | [] -> ()
+       | l ->
+           pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l)
+    x.ptyext_params
+    longident_loc x.ptyext_path
+    private_flag x.ptyext_private (* Cf: #7200 *)
+    (list ~sep:"" extension_constructor)
+    x.ptyext_constructors
+    (item_attributes ctxt) x.ptyext_attributes
+
+and constructor_declaration ctxt f (name, args, res, attrs) =
+  let name =
+    match name with
+    | "::" -> "(::)"
+    | s -> s in
+  match res with
+  | None ->
+      pp f "%s%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> ()
+           | Pcstr_tuple l ->
+             pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l
+           | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l
+        ) args
+        (attributes ctxt) attrs
+  | Some r ->
+      pp f "%s:@;%a@;%a" name
+        (fun f -> function
+           | Pcstr_tuple [] -> core_type1 ctxt f r
+           | Pcstr_tuple l -> pp f "%a@;->@;%a"
+                                (list (core_type1 ctxt) ~sep:"*@;") l
+                                (core_type1 ctxt) r
+           | Pcstr_record l ->
+               pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
+        )
+        args
+        (attributes ctxt) attrs
+
+and extension_constructor ctxt f x =
+  (* Cf: #7200 *)
+  match x.pext_kind with
+  | Pext_decl(l, r) ->
+      constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes)
+  | Pext_rebind li ->
+      pp f "%s%a@;=@;%a" x.pext_name.txt
+        (attributes ctxt) x.pext_attributes
+        longident_loc li
+
+and case_list ctxt f l : unit =
+  let aux f {pc_lhs; pc_guard; pc_rhs} =
+    pp f "@;| @[<2>%a%a@;->@;%a@]"
+      (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;")
+      pc_guard (expression (under_pipe ctxt)) pc_rhs
+  in
+  list aux f l ~sep:""
+
+and label_x_expression_param ctxt f (l,e) =
+  let simple_name = match e.pexp_desc with
     | Pexp_ident {txt=Lident l;_} -> Some l
     | _ -> None
-    in match l with
-    | Nolabel  -> self#expression2 f e ; (* level 2*)
-    | Optional str ->
-          if Some str = simple_name then
-            pp f "?%s" str
-          else
-            pp f "?%s:%a" str self#simple_expr e
-    | Labelled lbl ->
-          if Some lbl = simple_name then
-            pp f "~%s" lbl
-          else
-            pp f "~%s:%a" lbl self#simple_expr e
-
-  method directive_argument f x =
-    (match x with
-    | Pdir_none -> ()
-    | Pdir_string (s) -> pp f "@ %S" s
-    | Pdir_int (n,None) -> pp f "@ %s" n
-    | Pdir_int (n,Some m) -> pp f "@ %s%c" n m
-    | Pdir_ident (li) -> pp f "@ %a" self#longident li
-    | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
-
-  method toplevel_phrase f x =
-    match x with
-    | Ptop_def (s) ->
-        pp_open_hvbox f 0;
-        self#list self#structure_item f s ;
-        pp_close_box f ();
-    | Ptop_dir (s, da) ->
-        pp f "@[<hov2>#%s@ %a@]" s self#directive_argument da
-end;;
-
-
-let default = new printer ()
-
+  in match l with
+  | Nolabel  -> expression2 ctxt f e (* level 2*)
+  | Optional str ->
+      if Some str = simple_name then
+        pp f "?%s" str
+      else
+        pp f "?%s:%a" str (simple_expr ctxt) e
+  | Labelled lbl ->
+      if Some lbl = simple_name then
+        pp f "~%s" lbl
+      else
+        pp f "~%s:%a" lbl (simple_expr ctxt) e
+
+and directive_argument f x =
+  match x with
+  | Pdir_none -> ()
+  | Pdir_string (s) -> pp f "@ %S" s
+  | Pdir_int (n, None) -> pp f "@ %s" n
+  | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
+  | Pdir_ident (li) -> pp f "@ %a" longident li
+  | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
 
 let toplevel_phrase f x =
   match x with
-  | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (default#list default#structure_item) s
+  | Ptop_def (s) ->pp f "@[<hov0>%a@]"  (list (structure_item reset_ctxt)) s
    (* pp_open_hvbox f 0; *)
    (* pp_print_list structure_item f s ; *)
    (* pp_close_box f (); *)
   | Ptop_dir (s, da) ->
-   pp f "@[<hov2>#%s@ %a@]" s default#directive_argument da
+   pp f "@[<hov2>#%s@ %a@]" s directive_argument da
    (* pp f "@[<hov2>#%s@ %a@]" s directive_argument da *)
 
 let expression f x =
-  pp f "@[%a@]" default#expression x
-
+  pp f "@[%a@]" (expression reset_ctxt) x
 
 let string_of_expression x =
   ignore (flush_str_formatter ()) ;
   let f = str_formatter in
-  default#expression f x ;
-  flush_str_formatter () ;;
+  expression f x;
+  flush_str_formatter ()
+
 let string_of_structure x =
   ignore (flush_str_formatter ());
   let f = str_formatter in
-  default#structure f x;
-  flush_str_formatter ();;
+  structure reset_ctxt f x;
+  flush_str_formatter ()
 
 let top_phrase f x =
-  pp_print_newline f () ;
+  pp_print_newline f ();
   toplevel_phrase f x;
-  pp f ";;" ;
-  pp_print_newline f ();;
+  pp f ";;";
+  pp_print_newline f ()
 
-let core_type=default#core_type
-let pattern=default#pattern
-let signature=default#signature
-let structure=default#structure
+let core_type = core_type reset_ctxt
+let pattern = pattern reset_ctxt
+let signature = signature reset_ctxt
+let structure = structure reset_ctxt

diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli
index ec272254f549b8a62141e948c23fefccfa7ce15f..60f57cf4e73e64e4af8cdc322b645495b381935f 100644 (file)
--- a/parsing/pprintast.mli
+++ b/parsing/pprintast.mli
@@ -14,131 +14,7 @@
 (**************************************************************************)
 
 type space_formatter = (unit, Format.formatter, unit) format
-class printer :
-  unit ->
-  object ('b)
-    val pipe : bool
-    val semi : bool
-    method binding :
-      Format.formatter -> Parsetree.value_binding -> unit
-    method bindings:
-        Format.formatter ->
-          Asttypes.rec_flag * Parsetree.value_binding list ->
-            unit
-    method case_list :
-      Format.formatter -> Parsetree.case list -> unit
-    method class_expr : Format.formatter -> Parsetree.class_expr -> unit
-    method class_field : Format.formatter -> Parsetree.class_field -> unit
-    method class_params_def :
-      Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit
-    method class_signature :
-      Format.formatter -> Parsetree.class_signature -> unit
-    method class_structure :
-      Format.formatter -> Parsetree.class_structure -> unit
-    method class_type : Format.formatter -> Parsetree.class_type -> unit
-    method class_type_declaration_list :
-      Format.formatter -> Parsetree.class_type_declaration list -> unit
-    method constant : Format.formatter -> Parsetree.constant -> unit
-    method constant_string : Format.formatter -> string -> unit
-    method constructor_declaration :
-      Format.formatter -> (string * Parsetree.constructor_arguments
-                           * Parsetree.core_type option * Parsetree.attributes)
-        -> unit
-    method core_type : Format.formatter -> Parsetree.core_type -> unit
-    method core_type1 : Format.formatter -> Parsetree.core_type -> unit
-    method direction_flag :
-      Format.formatter -> Asttypes.direction_flag -> unit
-    method directive_argument :
-      Format.formatter -> Parsetree.directive_argument -> unit
-    method exception_declaration :
-      Format.formatter -> Parsetree.extension_constructor -> unit
-    method expression : Format.formatter -> Parsetree.expression -> unit
-    method expression1 : Format.formatter -> Parsetree.expression -> unit
-    method expression2 : Format.formatter -> Parsetree.expression -> unit
-    method extension_constructor :
-      Format.formatter -> Parsetree.extension_constructor -> unit
-    method label_exp :
-      Format.formatter ->
-      Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern ->
-      unit
-    method label_x_expression_param :
-      Format.formatter -> Asttypes.arg_label * Parsetree.expression -> unit
-    method list :
-      ?sep:space_formatter ->
-      ?first:space_formatter ->
-      ?last:space_formatter ->
-      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit
-    method longident : Format.formatter -> Longident.t -> unit
-    method longident_loc :
-      Format.formatter -> Longident.t Asttypes.loc -> unit
-    method module_expr : Format.formatter -> Parsetree.module_expr -> unit
-    method module_type : Format.formatter -> Parsetree.module_type -> unit
-    method mutable_flag : Format.formatter -> Asttypes.mutable_flag -> unit
-    method option :
-      ?first:space_formatter ->
-      ?last:space_formatter ->
-      (Format.formatter -> 'a -> unit) ->
-      Format.formatter -> 'a option -> unit
-    method paren :
-        ?first:space_formatter -> ?last:space_formatter -> bool ->
-          (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit
-    method pattern : Format.formatter -> Parsetree.pattern -> unit
-    method pattern1 : Format.formatter -> Parsetree.pattern -> unit
-    method payload : Format.formatter -> Parsetree.payload -> unit
-    method private_flag : Format.formatter -> Asttypes.private_flag -> unit
-    method rec_flag : Format.formatter -> Asttypes.rec_flag -> unit
-    method nonrec_flag : Format.formatter -> Asttypes.rec_flag -> unit
-    method record_declaration :
-        Format.formatter -> Parsetree.label_declaration list -> unit
 
-    method reset : 'b
-    method reset_semi : 'b
-    method reset_ifthenelse : 'b
-    method reset_pipe : 'b
-
-    method signature :
-      Format.formatter -> Parsetree.signature_item list -> unit
-    method signature_item :
-      Format.formatter -> Parsetree.signature_item -> unit
-    method simple_expr : Format.formatter -> Parsetree.expression -> unit
-    method simple_pattern : Format.formatter -> Parsetree.pattern -> unit
-    method string_quot : Format.formatter -> Asttypes.label -> unit
-    method structure :
-      Format.formatter -> Parsetree.structure_item list -> unit
-    method structure_item :
-      Format.formatter -> Parsetree.structure_item -> unit
-    method sugar_expr : Format.formatter -> Parsetree.expression -> bool
-    method toplevel_phrase :
-      Format.formatter -> Parsetree.toplevel_phrase -> unit
-    method type_declaration :
-      Format.formatter -> Parsetree.type_declaration -> unit
-    method type_def_list :
-      Format.formatter -> Asttypes.rec_flag * Parsetree.type_declaration list
-        -> unit
-    method type_extension :
-      Format.formatter -> Parsetree.type_extension -> unit
-    method type_param :
-      Format.formatter -> Parsetree.core_type * Asttypes.variance -> unit
-    method type_params :
-      Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit
-    method type_with_label :
-      Format.formatter -> Asttypes.arg_label * Parsetree.core_type -> unit
-    method tyvar : Format.formatter -> string -> unit
-    method under_pipe : 'b
-    method under_semi : 'b
-    method under_ifthenelse : 'b
-    method value_description :
-      Format.formatter -> Parsetree.value_description -> unit
-    method virtual_flag : Format.formatter -> Asttypes.virtual_flag -> unit
-    method attribute : Format.formatter -> Parsetree.attribute -> unit
-    method item_attribute : Format.formatter -> Parsetree.attribute -> unit
-    method floating_attribute : Format.formatter -> Parsetree.attribute -> unit
-    method attributes : Format.formatter -> Parsetree.attributes -> unit
-    method item_attributes : Format.formatter -> Parsetree.attributes -> unit
-    method extension : Format.formatter -> Parsetree.extension -> unit
-    method item_extension : Format.formatter -> Parsetree.extension -> unit
-  end
-val default : printer
 val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit
 val expression : Format.formatter -> Parsetree.expression -> unit
 val string_of_expression : Parsetree.expression -> string

diff --git a/parsing/printast.ml b/parsing/printast.ml
index 0f246db4938e58fe62cd5a2a4a83c2737cb1d7dc..673defb62c908b0247241656ac0dc166e7892428 100644 (file)
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -238,6 +238,9 @@ and pattern i ppf x =
   | Ppat_exception p ->
       line i ppf "Ppat_exception\n";
       pattern i ppf p
+  | Ppat_open (m,p) ->
+      line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m;
+      pattern i ppf p
   | Ppat_extension (s, arg) ->
       line i ppf "Ppat_extension \"%s\"\n" s.txt;
       payload i ppf arg
@@ -341,6 +344,10 @@ and expression i ppf x =
       line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
       module_expr i ppf me;
       expression i ppf e;
+  | Pexp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
   | Pexp_assert (e) ->
       line i ppf "Pexp_assert\n";
       expression i ppf e;

diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index 96ec79e205851f18645cf6a133f6b96b3b36c667..0bb55ab6769e7ed10bb59495f5ba0273adb267bc 100644 (file)
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -30,9 +30,9 @@ exception Escape_error
 
 let prepare_error = function
   | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      Location.errorf_prefixed ~loc:closing_loc
+      Location.errorf ~loc:closing_loc
         ~sub:[
-          Location.errorf_prefixed ~loc:opening_loc
+          Location.errorf ~loc:opening_loc
             "This '%s' might be unmatched" opening
         ]
         ~if_highlight:
@@ -42,24 +42,24 @@ let prepare_error = function
         "Syntax error: '%s' expected" closing
 
   | Expecting (loc, nonterm) ->
-      Location.errorf_prefixed ~loc "Syntax error: %s expected." nonterm
+      Location.errorf ~loc "Syntax error: %s expected." nonterm
   | Not_expecting (loc, nonterm) ->
-      Location.errorf_prefixed ~loc "Syntax error: %s not expected." nonterm
+      Location.errorf ~loc "Syntax error: %s not expected." nonterm
   | Applicative_path loc ->
-      Location.errorf_prefixed ~loc
+      Location.errorf ~loc
         "Syntax error: applicative paths of the form F(X).t \
          are not supported when the option -no-app-func is set."
   | Variable_in_scope (loc, var) ->
-      Location.errorf_prefixed ~loc
+      Location.errorf ~loc
         "In this scoped type, variable '%s \
          is reserved for the local type %s."
          var var
   | Other loc ->
-      Location.errorf_prefixed ~loc "Syntax error"
+      Location.errorf ~loc "Syntax error"
   | Ill_formed_ast (loc, s) ->
-      Location.errorf_prefixed ~loc "broken invariant in parsetree: %s" s
+      Location.errorf ~loc "broken invariant in parsetree: %s" s
   | Invalid_package_type (loc, s) ->
-      Location.errorf_prefixed ~loc "invalid package type: %s" s
+      Location.errorf ~loc "invalid package type: %s" s
 
 let () =
   Location.register_error_of_exn

diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index 364fbe3d32ce04c721bc9e317a1a8564b75aafaf..319eb57948e26d2a13f581fdcbc1718daea94f01 100644 (file)
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Auxiliary type for reporting syntax errors *)
+(** Auxiliary type for reporting syntax errors *)
 
 open Format
 
@@ -31,7 +31,7 @@ exception Error of error
 exception Escape_error
 
 val report_error: formatter -> error -> unit
- (* Deprecated.  Use Location.{error_of_exn, report_error}. *)
+ (** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *)
 
 val location_of_error: error -> Location.t
 val ill_formed_ast: Location.t -> string -> 'a

diff --git a/stdlib/.depend b/stdlib/.depend
index b3815165bf862cff35d9eabb25f59ce42b4d49ab..45827a92c925913bf35480b67c135622bb51955d 100644 (file)
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -1,186 +1,189 @@
-arg.cmi :
-array.cmi :
-arrayLabels.cmi :
-buffer.cmi :
-bytes.cmi :
-bytesLabels.cmi :
-callback.cmi :
-camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi
-camlinternalFormatBasics.cmi :
-camlinternalLazy.cmi :
-camlinternalMod.cmi : obj.cmi
-camlinternalOO.cmi : obj.cmi
-char.cmi :
-complex.cmi :
-digest.cmi :
-ephemeron.cmi : hashtbl.cmi
-filename.cmi :
-format.cmi : pervasives.cmi buffer.cmi
-gc.cmi :
-genlex.cmi : stream.cmi
-hashtbl.cmi :
-int32.cmi :
-int64.cmi :
-lazy.cmi :
-lexing.cmi :
-list.cmi :
-listLabels.cmi :
-map.cmi :
-marshal.cmi :
-moreLabels.cmi : set.cmi map.cmi hashtbl.cmi
-nativeint.cmi :
-obj.cmi : int32.cmi
-oo.cmi : camlinternalOO.cmi
-parsing.cmi : obj.cmi lexing.cmi
-pervasives.cmi : camlinternalFormatBasics.cmi
-printexc.cmi :
-printf.cmi : buffer.cmi
-queue.cmi :
-random.cmi : nativeint.cmi int64.cmi int32.cmi
-scanf.cmi : pervasives.cmi
-set.cmi :
-sort.cmi :
-stack.cmi :
-stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
-    arrayLabels.cmi
-stream.cmi :
-string.cmi :
-stringLabels.cmi :
-sys.cmi :
-uchar.cmi : format.cmi
-weak.cmi : hashtbl.cmi
 arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
     arg.cmi
 arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
     arg.cmi
+arg.cmi :
 array.cmo : array.cmi
 array.cmx : array.cmi
+array.cmi :
 arrayLabels.cmo : array.cmi arrayLabels.cmi
 arrayLabels.cmx : array.cmx arrayLabels.cmi
+arrayLabels.cmi :
 buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi
 buffer.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi
-bytes.cmo : pervasives.cmi list.cmi char.cmi bytes.cmi
-bytes.cmx : pervasives.cmx list.cmx char.cmx bytes.cmi
+buffer.cmi :
+bytes.cmo : pervasives.cmi char.cmi bytes.cmi
+bytes.cmx : pervasives.cmx char.cmx bytes.cmi
+bytes.cmi :
 bytesLabels.cmo : bytes.cmi bytesLabels.cmi
 bytesLabels.cmx : bytes.cmx bytesLabels.cmi
+bytesLabels.cmi :
 callback.cmo : obj.cmi callback.cmi
 callback.cmx : obj.cmx callback.cmi
+callback.cmi :
 camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \
     camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi
 camlinternalFormat.cmx : sys.cmx string.cmx char.cmx \
     camlinternalFormatBasics.cmx bytes.cmx buffer.cmx camlinternalFormat.cmi
+camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi
 camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi
 camlinternalFormatBasics.cmx : camlinternalFormatBasics.cmi
+camlinternalFormatBasics.cmi :
 camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
 camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi
+camlinternalLazy.cmi :
 camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
     camlinternalMod.cmi
 camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \
     camlinternalMod.cmi
+camlinternalMod.cmi : obj.cmi
 camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
     array.cmi camlinternalOO.cmi
 camlinternalOO.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
     array.cmx camlinternalOO.cmi
+camlinternalOO.cmi : obj.cmi
 char.cmo : char.cmi
 char.cmx : char.cmi
+char.cmi :
 complex.cmo : complex.cmi
 complex.cmx : complex.cmi
+complex.cmi :
 digest.cmo : string.cmi char.cmi bytes.cmi digest.cmi
 digest.cmx : string.cmx char.cmx bytes.cmx digest.cmi
+digest.cmi :
 ephemeron.cmo : sys.cmi random.cmi obj.cmi lazy.cmi hashtbl.cmi array.cmi \
     ephemeron.cmi
 ephemeron.cmx : sys.cmx random.cmx obj.cmx lazy.cmx hashtbl.cmx array.cmx \
     ephemeron.cmi
+ephemeron.cmi : hashtbl.cmi
 filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \
     filename.cmi
 filename.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \
     filename.cmi
+filename.cmi :
 format.cmo : string.cmi pervasives.cmi camlinternalFormatBasics.cmi \
     camlinternalFormat.cmi buffer.cmi format.cmi
 format.cmx : string.cmx pervasives.cmx camlinternalFormatBasics.cmx \
     camlinternalFormat.cmx buffer.cmx format.cmi
+format.cmi : pervasives.cmi buffer.cmi
 gc.cmo : sys.cmi string.cmi printf.cmi gc.cmi
 gc.cmx : sys.cmx string.cmx printf.cmx gc.cmi
+gc.cmi :
 genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi bytes.cmi \
     genlex.cmi
 genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx bytes.cmx \
     genlex.cmi
+genlex.cmi : stream.cmi
 hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \
     hashtbl.cmi
 hashtbl.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \
     hashtbl.cmi
+hashtbl.cmi :
 int32.cmo : pervasives.cmi int32.cmi
 int32.cmx : pervasives.cmx int32.cmi
+int32.cmi :
 int64.cmo : pervasives.cmi int64.cmi
 int64.cmx : pervasives.cmx int64.cmi
+int64.cmi :
 lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
 lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi
+lazy.cmi :
 lexing.cmo : sys.cmi string.cmi bytes.cmi array.cmi lexing.cmi
 lexing.cmx : sys.cmx string.cmx bytes.cmx array.cmx lexing.cmi
+lexing.cmi :
 list.cmo : list.cmi
 list.cmx : list.cmi
+list.cmi :
 listLabels.cmo : list.cmi listLabels.cmi
 listLabels.cmx : list.cmx listLabels.cmi
+listLabels.cmi :
 map.cmo : map.cmi
 map.cmx : map.cmi
+map.cmi :
 marshal.cmo : bytes.cmi marshal.cmi
 marshal.cmx : bytes.cmx marshal.cmi
+marshal.cmi :
 moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
 moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi
+moreLabels.cmi : set.cmi map.cmi hashtbl.cmi
 nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
 nativeint.cmx : sys.cmx pervasives.cmx nativeint.cmi
+nativeint.cmi :
 obj.cmo : marshal.cmi int32.cmi obj.cmi
 obj.cmx : marshal.cmx int32.cmx obj.cmi
+obj.cmi : int32.cmi
 oo.cmo : camlinternalOO.cmi oo.cmi
 oo.cmx : camlinternalOO.cmx oo.cmi
+oo.cmi : camlinternalOO.cmi
 parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
 parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi
+parsing.cmi : obj.cmi lexing.cmi
 pervasives.cmo : camlinternalFormatBasics.cmi pervasives.cmi
 pervasives.cmx : camlinternalFormatBasics.cmx pervasives.cmi
+pervasives.cmi : camlinternalFormatBasics.cmi
 printexc.cmo : printf.cmi pervasives.cmi obj.cmi buffer.cmi array.cmi \
     printexc.cmi
 printexc.cmx : printf.cmx pervasives.cmx obj.cmx buffer.cmx array.cmx \
     printexc.cmi
+printexc.cmi :
 printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi buffer.cmi \
     printf.cmi
 printf.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx buffer.cmx \
     printf.cmi
+printf.cmi : buffer.cmi
 queue.cmo : queue.cmi
 queue.cmx : queue.cmi
+queue.cmi :
 random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
     digest.cmi char.cmi array.cmi random.cmi
 random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
     digest.cmx char.cmx array.cmx random.cmi
+random.cmi : nativeint.cmi int64.cmi int32.cmi
 scanf.cmo : string.cmi printf.cmi pervasives.cmi list.cmi \
     camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \
     scanf.cmi
 scanf.cmx : string.cmx printf.cmx pervasives.cmx list.cmx \
     camlinternalFormatBasics.cmx camlinternalFormat.cmx bytes.cmx buffer.cmx \
     scanf.cmi
+scanf.cmi : pervasives.cmi
 set.cmo : list.cmi set.cmi
 set.cmx : list.cmx set.cmi
+set.cmi :
 sort.cmo : array.cmi sort.cmi
 sort.cmx : array.cmx sort.cmi
+sort.cmi :
+spacetime.cmo : gc.cmi spacetime.cmi
+spacetime.cmx : gc.cmx spacetime.cmi
+spacetime.cmi :
 stack.cmo : list.cmi stack.cmi
 stack.cmx : list.cmx stack.cmi
+stack.cmi :
 stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
     arrayLabels.cmi stdLabels.cmi
 stdLabels.cmx : stringLabels.cmx listLabels.cmx bytesLabels.cmx \
     arrayLabels.cmx stdLabels.cmi
+stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
+    arrayLabels.cmi
 std_exit.cmo :
 std_exit.cmx :
 stream.cmo : string.cmi list.cmi lazy.cmi bytes.cmi stream.cmi
 stream.cmx : string.cmx list.cmx lazy.cmx bytes.cmx stream.cmi
-string.cmo : pervasives.cmi list.cmi bytes.cmi string.cmi
-string.cmx : pervasives.cmx list.cmx bytes.cmx string.cmi
+stream.cmi :
+string.cmo : pervasives.cmi bytes.cmi string.cmi
+string.cmx : pervasives.cmx bytes.cmx string.cmi
+string.cmi :
 stringLabels.cmo : string.cmi stringLabels.cmi
 stringLabels.cmx : string.cmx stringLabels.cmi
+stringLabels.cmi :
 sys.cmo : sys.cmi
 sys.cmx : sys.cmi
+sys.cmi :
 uchar.cmo : printf.cmi pervasives.cmi format.cmi char.cmi uchar.cmi
 uchar.cmx : printf.cmx pervasives.cmx format.cmx char.cmx uchar.cmi
+uchar.cmi : format.cmi
 weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
 weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
+weak.cmi : hashtbl.cmi
 arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
     arg.cmi
 arg.p.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
@@ -191,8 +194,8 @@ arrayLabels.cmo : array.cmi arrayLabels.cmi
 arrayLabels.p.cmx : array.cmx arrayLabels.cmi
 buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi
 buffer.p.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi
-bytes.cmo : pervasives.cmi list.cmi char.cmi bytes.cmi
-bytes.p.cmx : pervasives.cmx list.cmx char.cmx bytes.cmi
+bytes.cmo : pervasives.cmi char.cmi bytes.cmi
+bytes.p.cmx : pervasives.cmx char.cmx bytes.cmi
 bytesLabels.cmo : bytes.cmi bytesLabels.cmi
 bytesLabels.p.cmx : bytes.cmx bytesLabels.cmi
 callback.cmo : obj.cmi callback.cmi
@@ -293,6 +296,8 @@ set.cmo : list.cmi set.cmi
 set.p.cmx : list.cmx set.cmi
 sort.cmo : array.cmi sort.cmi
 sort.p.cmx : array.cmx sort.cmi
+spacetime.cmo : gc.cmi spacetime.cmi
+spacetime.p.cmx : gc.cmx spacetime.cmi
 stack.cmo : list.cmi stack.cmi
 stack.p.cmx : list.cmx stack.cmi
 stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \
@@ -303,8 +308,8 @@ std_exit.cmo :
 std_exit.cmx :
 stream.cmo : string.cmi list.cmi lazy.cmi bytes.cmi stream.cmi
 stream.p.cmx : string.cmx list.cmx lazy.cmx bytes.cmx stream.cmi
-string.cmo : pervasives.cmi list.cmi bytes.cmi string.cmi
-string.p.cmx : pervasives.cmx list.cmx bytes.cmx string.cmi
+string.cmo : pervasives.cmi bytes.cmi string.cmi
+string.p.cmx : pervasives.cmx bytes.cmx string.cmi
 stringLabels.cmo : string.cmi stringLabels.cmi
 stringLabels.p.cmx : string.cmx stringLabels.cmi
 sys.cmo : sys.cmi

diff --git a/stdlib/Makefile b/stdlib/Makefile
index 2beea0f2fee1d3a96319763cf8ee8d694158f536..05ee26ab86fdbafdc08bab7a6778c73eba568f2d 100644 (file)
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -52,7 +52,7 @@ camlheader target_camlheader camlheader_ur \
 camlheaderd target_camlheaderd \
 camlheaderi target_camlheaderi: \
   header.c ../config/Makefile
-       if $(SHARPBANGSCRIPTS); then \
+       if $(HASHBANGSCRIPTS); then \
          for suff in '' d i; do \
            echo '#!$(BINDIR)/ocamlrun'$$suff > camlheader$$suff && \
            echo '#!$(TARGET_BINDIR)/ocamlrun'$$suff >target_camlheader$$suff; \

diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared
index 0af8601bfbc07eca9d33a17064ccb43d8c379d61..1956657a879339594a082bfa02d0c0c29244a3e8 100755 (executable)
--- a/stdlib/Makefile.shared
+++ b/stdlib/Makefile.shared
@@ -20,8 +20,9 @@ TARGET_BINDIR ?= $(BINDIR)
 
 COMPILER=../ocamlc
 CAMLC=$(CAMLRUN) $(COMPILER)
-COMPFLAGS=-strict-sequence -w +32+33..39+50 -g -warn-error A -bin-annot \
-         -nostdlib -safe-string
+COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48 \
+          -g -warn-error A -bin-annot -nostdlib \
+          -safe-string -strict-formats
 ifeq "$(FLAMBDA)" "true"
 OPTCOMPFLAGS=-O3
 else
@@ -46,7 +47,8 @@ OTHERS=list.cmo char.cmo bytes.cmo string.cmo sys.cmo \
   genlex.cmo ephemeron.cmo \
   filename.cmo complex.cmo \
   arrayLabels.cmo listLabels.cmo bytesLabels.cmo \
-  stringLabels.cmo moreLabels.cmo stdLabels.cmo
+  stringLabels.cmo moreLabels.cmo stdLabels.cmo \
+  spacetime.cmo
 
 all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur
 
@@ -107,8 +109,9 @@ clean::
                   -p -c -o $*.p.cmx $<
 
 # Dependencies on the compiler
-$(OBJS) std_exit.cmo: $(COMPILER)
-$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
+COMPILER_DEPS=$(filter-out -use-prims, $(COMPILER))
+$(OBJS) std_exit.cmo: $(COMPILER_DEPS)
+$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER_DEPS)
 $(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER)
 $(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER)
 
@@ -131,5 +134,5 @@ include .depend
 # .p.cmx files.  When the compiler imports another compilation unit,
 # it looks for the .cmx file (not .p.cmx).
 depend:
-       $(CAMLDEP) *.mli *.ml > .depend
-       $(CAMLDEP) *.ml | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend
+       $(CAMLDEP) -slash *.mli *.ml > .depend
+       $(CAMLDEP) -slash *.ml | sed -e 's/\.cmx : /.p.cmx : /g' >>.depend

diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index 1f516b9b6997d35254e5319b615bfeb1eba162d2..b65e9debbb33e4d76968b4f5ac82eab0562625b6 100644 (file)
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -19,6 +19,7 @@
 # It is used in particular to know what to expunge in toplevels.
 
 STDLIB_MODULES=\
+  spacetime \
   arg \
   array \
   arrayLabels \

diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 65435c5f6c5bccdd53440337a7a3291a917f42ff..9b0bce992325c5048aa5c3c85e78d230b03e0ed8 100644 (file)
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -53,7 +53,7 @@ open Printf
 let rec assoc3 x l =
   match l with
   | [] -> raise Not_found
-  | (y1, y2, y3) :: t when y1 = x -> y2
+  | (y1, y2, _) :: _ when y1 = x -> y2
   | _ :: t -> assoc3 x t
 
 
@@ -293,7 +293,7 @@ let add_padding len ksd =
       (* Do not pad undocumented options, so that they still don't show up when
        * run through [usage] or [parse]. *)
       ksd
-  | (kwd, (Symbol (l, _) as spec), msg) ->
+  | (kwd, (Symbol _ as spec), msg) ->
       let cutcol = second_word msg in
       let spaces = String.make ((max 0 (len - cutcol)) + 3) ' ' in
       (kwd, spec, "\n" ^ spaces ^ msg)

diff --git a/stdlib/array.ml b/stdlib/array.ml
index 9b19843cf979c127a9afeac884fd56af730e50c8..a4270f278a6c12d31750f9f4f2542129097728b8 100644 (file)
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -131,8 +131,7 @@ let to_list a =
 (* Cannot use List.length here because the List module depends on Array. *)
 let rec list_length accu = function
   | [] -> accu
-  | h::t -> list_length (succ accu) t
-
+  | _::t -> list_length (succ accu) t
 
 let of_list = function
     [] -> [||]

diff --git a/stdlib/array.mli b/stdlib/array.mli
index 872423df9b148755e6b61507e2b51fd048e497b8..f75b613760527ceec7ee6d5201ea08cf5b1996e1 100644 (file)
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -174,13 +174,15 @@ val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
 val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
 (** [Array.iter2 f a b] applies function [f] to all the elements of [a]
    and [b].
-   Raise [Invalid_argument] if the arrays are not the same size. *)
+   Raise [Invalid_argument] if the arrays are not the same size.
+   @since 4.03.0 *)
 
 val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
 (** [Array.map2 f a b] applies function [f] to all the elements of [a]
    and [b], and builds an array with the results returned by [f]:
    [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]].
-   Raise [Invalid_argument] if the arrays are not the same size. *)
+   Raise [Invalid_argument] if the arrays are not the same size.
+   @since 4.03.0 *)
 
 
 (** {6 Array scanning} *)
@@ -189,20 +191,24 @@ val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
 val for_all : ('a -> bool) -> 'a array -> bool
 (** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array
    satisfy the predicate [p]. That is, it returns
-   [(p a1) && (p a2) && ... && (p an)]. *)
+   [(p a1) && (p a2) && ... && (p an)].
+   @since 4.03.0 *)
 
 val exists : ('a -> bool) -> 'a array -> bool
 (** [Array.exists p [|a1; ...; an|]] checks if at least one element of
     the array satisfies the predicate [p]. That is, it returns
-    [(p a1) || (p a2) || ... || (p an)]. *)
+    [(p a1) || (p a2) || ... || (p an)].
+    @since 4.03.0 *)
 
 val mem : 'a -> 'a array -> bool
 (** [mem a l] is true if and only if [a] is equal
-   to an element of [l]. *)
+   to an element of [l].
+   @since 4.03.0 *)
 
 val memq : 'a -> 'a array -> bool
 (** Same as {!Array.mem}, but uses physical equality instead of structural
-   equality to compare array elements. *)
+   equality to compare array elements.
+   @since 4.03.0 *)
 
 
 (** {6 Sorting} *)

diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index 3a2668a1f962817a420f380f5d95c3f39aae4791..51ab641279c8c7f75df32edb3bd8be01a356c75e 100644 (file)
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -81,7 +81,7 @@ let add_char b c =
   b.position <- pos + 1
 
 let add_substring b s offset len =
-  if offset < 0 || len < 0 || offset + len > String.length s
+  if offset < 0 || len < 0 || offset > String.length s - len
   then invalid_arg "Buffer.add_substring/add_subbytes";
   let new_position = b.position + len in
   if new_position > b.length then resize b len;

diff --git a/stdlib/bytes.ml b/stdlib/bytes.ml
index 7ee98d5e80e6338f1926f7145ffebba148ed5fc2..24e97cce1434c168ebb88475ddd143afb79e7b01 100644 (file)
--- a/stdlib/bytes.ml
+++ b/stdlib/bytes.ml
@@ -15,20 +15,26 @@
 
 (* Byte sequence operations *)
 
-external length : bytes -> int = "%string_length"
+(* WARNING: Some functions in this file are duplicated in string.ml for
+   efficiency reasons. When you modify the one in this file you need to
+   modify its duplicate in string.ml.
+   These functions have a "duplicated" comment above their definition.
+*)
+
+external length : bytes -> int = "%bytes_length"
 external string_length : string -> int = "%string_length"
-external get : bytes -> int -> char = "%string_safe_get"
-external set : bytes -> int -> char -> unit = "%string_safe_set"
-external create : int -> bytes = "caml_create_string"
-external unsafe_get : bytes -> int -> char = "%string_unsafe_get"
-external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+external get : bytes -> int -> char = "%bytes_safe_get"
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
+external create : int -> bytes = "caml_create_bytes"
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
 external unsafe_fill : bytes -> int -> int -> char -> unit
-                     = "caml_fill_string" [@@noalloc]
-external unsafe_to_string : bytes -> string = "%identity"
-external unsafe_of_string : string -> bytes = "%identity"
+                     = "caml_fill_bytes" [@@noalloc]
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
+external unsafe_of_string : string -> bytes = "%bytes_of_string"
 
 external unsafe_blit : bytes -> int -> bytes -> int -> int -> unit
-                     = "caml_blit_string" [@@noalloc]
+                     = "caml_blit_bytes" [@@noalloc]
 external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
                      = "caml_blit_string" [@@noalloc]
 
@@ -91,29 +97,36 @@ let blit_string s1 ofs1 s2 ofs2 len =
   then invalid_arg "String.blit / Bytes.blit_string"
   else unsafe_blit_string s1 ofs1 s2 ofs2 len
 
+(* duplicated in string.ml *)
 let iter f a =
   for i = 0 to length a - 1 do f(unsafe_get a i) done
 
+(* duplicated in string.ml *)
 let iteri f a =
   for i = 0 to length a - 1 do f i (unsafe_get a i) done
 
-let concat sep l =
-  match l with
-    [] -> empty
+let ensure_ge x y = if x >= y then x else invalid_arg "Bytes.concat"
+
+let rec sum_lengths acc seplen = function
+  | [] -> acc
+  | hd :: [] -> length hd + acc
+  | hd :: tl -> sum_lengths (ensure_ge (length hd + seplen + acc) acc) seplen tl
+
+let rec unsafe_blits dst pos sep seplen = function
+    [] -> dst
+  | hd :: [] ->
+    unsafe_blit hd 0 dst pos (length hd); dst
   | hd :: tl ->
-      let num = ref 0 and len = ref 0 in
-      List.iter (fun s -> incr num; len := !len + length s) l;
-      let r = create (!len + length sep * (!num - 1)) in
-      unsafe_blit hd 0 r 0 (length hd);
-      let pos = ref(length hd) in
-      List.iter
-        (fun s ->
-          unsafe_blit sep 0 r !pos (length sep);
-          pos := !pos + length sep;
-          unsafe_blit s 0 r !pos (length s);
-          pos := !pos + length s)
-        tl;
-      r
+    unsafe_blit hd 0 dst pos (length hd);
+    unsafe_blit sep 0 dst (pos + length hd) seplen;
+    unsafe_blits dst (pos + length hd + seplen) sep seplen tl
+
+let concat sep = function
+    [] -> empty
+  | l -> let seplen = length sep in
+          unsafe_blits 
+            (create (sum_lengths 0 seplen l))
+            0 sep seplen l
 
 let cat s1 s2 =
   let l1 = length s1 in
@@ -215,23 +228,29 @@ let apply1 f s =
 let capitalize_ascii s = apply1 Char.uppercase_ascii s
 let uncapitalize_ascii s = apply1 Char.lowercase_ascii s
 
+(* duplicated in string.ml *)
 let rec index_rec s lim i c =
   if i >= lim then raise Not_found else
   if unsafe_get s i = c then i else index_rec s lim (i + 1) c
 
+(* duplicated in string.ml *)
 let index s c = index_rec s (length s) 0 c
 
+(* duplicated in string.ml *)
 let index_from s i c =
   let l = length s in
   if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
   index_rec s l i c
 
+(* duplicated in string.ml *)
 let rec rindex_rec s i c =
   if i < 0 then raise Not_found else
   if unsafe_get s i = c then i else rindex_rec s (i - 1) c
 
+(* duplicated in string.ml *)
 let rindex s c = rindex_rec s (length s - 1) c
 
+(* duplicated in string.ml *)
 let rindex_from s i c =
   if i < -1 || i >= length s then
     invalid_arg "String.rindex_from / Bytes.rindex_from"
@@ -239,6 +258,7 @@ let rindex_from s i c =
     rindex_rec s i c
 
 
+(* duplicated in string.ml *)
 let contains_from s i c =
   let l = length s in
   if i < 0 || i > l then
@@ -247,8 +267,10 @@ let contains_from s i c =
     try ignore (index_rec s l i c); true with Not_found -> false
 
 
+(* duplicated in string.ml *)
 let contains s c = contains_from s 0 c
 
+(* duplicated in string.ml *)
 let rcontains_from s i c =
   if i < 0 || i >= length s then
     invalid_arg "String.rcontains_from / Bytes.rcontains_from"
@@ -259,7 +281,7 @@ let rcontains_from s i c =
 type t = bytes
 
 let compare (x: t) (y: t) = Pervasives.compare x y
-external equal : t -> t -> bool = "caml_string_equal"
+external equal : t -> t -> bool = "caml_bytes_equal"
 
 (* Deprecated functions implemented via other deprecated functions *)
 [@@@ocaml.warning "-3"]

diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli
index 3b03382ceb2dc4e109fdc9d8f3a8f53d5ccc1fe8..a6172d8519c28cdaafdcbf53a286549a91019d14 100644 (file)
--- a/stdlib/bytes.mli
+++ b/stdlib/bytes.mli
@@ -42,21 +42,21 @@
    @since 4.02.0
  *)
 
-external length : bytes -> int = "%string_length"
+external length : bytes -> int = "%bytes_length"
 (** Return the length (number of bytes) of the argument. *)
 
-external get : bytes -> int -> char = "%string_safe_get"
+external get : bytes -> int -> char = "%bytes_safe_get"
 (** [get s n] returns the byte at index [n] in argument [s].
 
     Raise [Invalid_argument] if [n] not a valid index in [s]. *)
 
-external set : bytes -> int -> char -> unit = "%string_safe_set"
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
 (** [set s n c] modifies [s] in place, replacing the byte at index [n]
     with [c].
 
     Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
 
-external create : int -> bytes = "caml_create_string"
+external create : int -> bytes = "caml_create_bytes"
 (** [create n] returns a new byte sequence of length [n]. The
     sequence is uninitialized and contains arbitrary bytes.
 
@@ -424,10 +424,10 @@ let s = Bytes.of_string "hello"
 
 (* The following is for system use only. Do not call directly. *)
 
-external unsafe_get : bytes -> int -> char = "%string_unsafe_get"
-external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
 external unsafe_blit :
   bytes -> int -> bytes -> int -> int -> unit
-  = "caml_blit_string" [@@noalloc]
+  = "caml_blit_bytes" [@@noalloc]
 external unsafe_fill :
-  bytes -> int -> int -> char -> unit = "caml_fill_string" [@@noalloc]
+  bytes -> int -> int -> char -> unit = "caml_fill_bytes" [@@noalloc]

diff --git a/stdlib/bytesLabels.mli b/stdlib/bytesLabels.mli
index b22139e823f9bd16d2bffbfc3c076127c7d882c7..fb9404b92bf06d0cdbfd1997221f4183ad115377 100644 (file)
--- a/stdlib/bytesLabels.mli
+++ b/stdlib/bytesLabels.mli
@@ -17,22 +17,22 @@
     @since 4.02.0
  *)
 
-external length : bytes -> int = "%string_length"
+external length : bytes -> int = "%bytes_length"
 (** Return the length (number of bytes) of the argument. *)
 
-external get : bytes -> int -> char = "%string_safe_get"
+external get : bytes -> int -> char = "%bytes_safe_get"
 (** [get s n] returns the byte at index [n] in argument [s].
 
     Raise [Invalid_argument] if [n] not a valid index in [s]. *)
 
 
-external set : bytes -> int -> char -> unit = "%string_safe_set"
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
 (** [set s n c] modifies [s] in place, replacing the byte at index [n]
     with [c].
 
     Raise [Invalid_argument] if [n] is not a valid index in [s]. *)
 
-external create : int -> bytes = "caml_create_string"
+external create : int -> bytes = "caml_create_bytes"
 (** [create n] returns a new byte sequence of length [n]. The
     sequence is uninitialized and contains arbitrary bytes.
 
@@ -206,12 +206,12 @@ val compare: t -> t -> int
 
 (* The following is for system use only. Do not call directly. *)
 
-external unsafe_get : bytes -> int -> char = "%string_unsafe_get"
-external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set"
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
 external unsafe_blit :
   src:bytes -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int ->
-    unit = "caml_blit_string" [@@noalloc]
+    unit = "caml_blit_bytes" [@@noalloc]
 external unsafe_fill :
-  bytes -> pos:int -> len:int -> char -> unit = "caml_fill_string" [@@noalloc]
+  bytes -> pos:int -> len:int -> char -> unit = "caml_fill_bytes" [@@noalloc]
 val unsafe_to_string : bytes -> string
 val unsafe_of_string : string -> bytes

diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml
index 2391af782e418babb47616e40b9cdfc4bfbbe141..9c0574dd796ea7950f48765fd4e2b9873ea0251f 100644 (file)
--- a/stdlib/camlinternalFormat.ml
+++ b/stdlib/camlinternalFormat.ml
@@ -2012,7 +2012,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
   (*   - zero:  is the '0' flag defined in the current micro-format.  *)
   (*   - minus: is the '-' flag defined in the current micro-format.  *)
   (*   - plus:  is the '+' flag defined in the current micro-format.  *)
-  (*   - sharp: is the '#' flag defined in the current micro-format.  *)
+  (*   - hash:  is the '#' flag defined in the current micro-format.  *)
   (*   - space: is the ' ' flag defined in the current micro-format.  *)
   (*   - ign:   is the '_' flag defined in the current micro-format.  *)
   (*   - pad: padding of the current micro-format.                    *)
@@ -2105,7 +2105,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
   fun pct_ind str_ind end_ind ign ->
     let zero = ref false and minus = ref false
     and plus = ref false and space = ref false
-    and sharp = ref false in
+    and hash = ref false in
     let set_flag str_ind flag =
       (* in legacy mode, duplicate flags are accepted *)
       if !flag && not legacy_behavior then
@@ -2120,11 +2120,11 @@ let fmt_ebb_of_string ?legacy_behavior str =
       | '0' -> set_flag str_ind zero;  read_flags (str_ind + 1)
       | '-' -> set_flag str_ind minus; read_flags (str_ind + 1)
       | '+' -> set_flag str_ind plus;  read_flags (str_ind + 1)
-      | '#' -> set_flag str_ind sharp; read_flags (str_ind + 1)
+      | '#' -> set_flag str_ind hash; read_flags (str_ind + 1)
       | ' ' -> set_flag str_ind space; read_flags (str_ind + 1)
       | _ ->
         parse_padding pct_ind str_ind end_ind
-          !zero !minus !plus !sharp !space ign
+          !zero !minus !plus !hash !space ign
       end
     in
     read_flags str_ind
@@ -2133,7 +2133,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
   and parse_padding : type e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> bool -> bool ->
         (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind zero minus plus sharp space ign ->
+  fun pct_ind str_ind end_ind zero minus plus hash space ign ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     let padty = match zero, minus with
       | false, false -> Right
@@ -2145,26 +2145,26 @@ let fmt_ebb_of_string ?legacy_behavior str =
     match str.[str_ind] with
     | '0' .. '9' ->
       let new_ind, width = parse_positive str_ind end_ind 0 in
-      parse_after_padding pct_ind new_ind end_ind minus plus sharp space ign
+      parse_after_padding pct_ind new_ind end_ind minus plus hash space ign
         (Lit_padding (padty, width))
     | '*' ->
-      parse_after_padding pct_ind (str_ind + 1) end_ind minus plus sharp space
+      parse_after_padding pct_ind (str_ind + 1) end_ind minus plus hash space
         ign (Arg_padding padty)
     | _ ->
       begin match padty with
       | Left  ->
         if not legacy_behavior then
           invalid_format_without (str_ind - 1) '-' "padding";
-        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
           No_padding
       | Zeros ->
          (* a '0' padding indication not followed by anything should
            be interpreted as a Right padding of width 0. This is used
            by scanning conversions %0s and %0c *)
-        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
           (Lit_padding (Right, 0))
       | Right ->
-        parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign
+        parse_after_padding pct_ind str_ind end_ind minus plus hash space ign
           No_padding
       end
 
@@ -2172,25 +2172,25 @@ let fmt_ebb_of_string ?legacy_behavior str =
   and parse_after_padding : type x e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
         (x, _) padding -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind minus plus sharp space ign pad ->
+  fun pct_ind str_ind end_ind minus plus hash space ign pad ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     match str.[str_ind] with
     | '.' ->
-      parse_precision pct_ind (str_ind + 1) end_ind minus plus sharp space ign
+      parse_precision pct_ind (str_ind + 1) end_ind minus plus hash space ign
         pad
     | symb ->
-      parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad
+      parse_conversion pct_ind (str_ind + 1) end_ind plus hash space ign pad
         No_precision pad symb
 
   (* Read the digital or '*' precision. *)
   and parse_precision : type x e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
         (x, _) padding -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind minus plus sharp space ign pad ->
+  fun pct_ind str_ind end_ind minus plus hash space ign pad ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     let parse_literal minus str_ind =
       let new_ind, prec = parse_positive str_ind end_ind 0 in
-      parse_after_precision pct_ind new_ind end_ind minus plus sharp space ign
+      parse_after_precision pct_ind new_ind end_ind minus plus hash space ign
         pad (Lit_precision prec) in
     match str.[str_ind] with
     | '0' .. '9' -> parse_literal minus str_ind
@@ -2205,14 +2205,14 @@ let fmt_ebb_of_string ?legacy_behavior str =
          still blatantly wrong, as 123_456 or 0xFF are rejected. *)
       parse_literal (minus || symb = '-') (str_ind + 1)
     | '*' ->
-      parse_after_precision pct_ind (str_ind + 1) end_ind minus plus sharp space
+      parse_after_precision pct_ind (str_ind + 1) end_ind minus plus hash space
         ign pad Arg_precision
     | _ ->
       if legacy_behavior then
         (* note that legacy implementation did not ignore '.' without
            a number (as it does for padding indications), but
            interprets it as '.0' *)
-        parse_after_precision pct_ind str_ind end_ind minus plus sharp space ign
+        parse_after_precision pct_ind str_ind end_ind minus plus hash space ign
           pad (Lit_precision 0)
       else
         invalid_format_without (str_ind - 1) '.' "precision"
@@ -2221,10 +2221,10 @@ let fmt_ebb_of_string ?legacy_behavior str =
   and parse_after_precision : type x y z t e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> bool ->
         (x, y) padding -> (z, t) precision -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind minus plus sharp space ign pad prec ->
+  fun pct_ind str_ind end_ind minus plus hash space ign pad prec ->
     if str_ind = end_ind then unexpected_end_of_format end_ind;
     let parse_conv (type u) (type v) (padprec : (u, v) padding) =
-      parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad
+      parse_conversion pct_ind (str_ind + 1) end_ind plus hash space ign pad
         prec padprec str.[str_ind] in
     (* in legacy mode, some formats (%s and %S) accept a weird mix of
        padding and precision, which is merged as a single padding
@@ -2247,15 +2247,15 @@ let fmt_ebb_of_string ?legacy_behavior str =
   and parse_conversion : type x y z t u v e f .
       int -> int -> int -> bool -> bool -> bool -> bool -> (x, y) padding ->
         (z, t) precision -> (u, v) padding -> char -> (_, _, e, f) fmt_ebb =
-  fun pct_ind str_ind end_ind plus sharp space ign pad prec padprec symb ->
+  fun pct_ind str_ind end_ind plus hash space ign pad prec padprec symb ->
     (* Flags used to check option usages/compatibilities. *)
-    let plus_used  = ref false and sharp_used = ref false
+    let plus_used  = ref false and hash_used = ref false
     and space_used = ref false and ign_used   = ref false
     and pad_used   = ref false and prec_used  = ref false in
 
     (* Access to options, update flags. *)
     let get_plus    () = plus_used  := true; plus
-    and get_sharp   () = sharp_used := true; sharp
+    and get_hash   () = hash_used := true; hash
     and get_space   () = space_used := true; space
     and get_ign     () = ign_used   := true; ign
     and get_pad     () = pad_used   := true; pad
@@ -2374,7 +2374,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
           make_padding_fmt_ebb pad fmt_rest in
         Fmt_EBB (Caml_string (pad', fmt_rest'))
     | 'd' | 'i' | 'x' | 'X' | 'o' | 'u' ->
-      let iconv = compute_int_conv pct_ind str_ind (get_plus ()) (get_sharp ())
+      let iconv = compute_int_conv pct_ind str_ind (get_plus ()) (get_hash ())
         (get_space ()) symb in
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
       if get_ign () then
@@ -2402,7 +2402,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
         Fmt_EBB (Scan_get_counter (counter, fmt_rest))
     | 'l' ->
       let iconv =
-        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_sharp ())
+        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_hash ())
           (get_space ()) str.[str_ind] in
       let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
       if get_ign () then
@@ -2415,7 +2415,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | 'n' ->
       let iconv =
         compute_int_conv pct_ind (str_ind + 1) (get_plus ())
-          (get_sharp ()) (get_space ()) str.[str_ind] in
+          (get_hash ()) (get_space ()) str.[str_ind] in
       let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
       if get_ign () then
         let ignored = Ignored_nativeint (iconv, get_pad_opt '_') in
@@ -2426,7 +2426,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
         Fmt_EBB (Nativeint (iconv, pad', prec', fmt_rest'))
     | 'L' ->
       let iconv =
-        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_sharp ())
+        compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_hash ())
           (get_space ()) str.[str_ind] in
       let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
       if get_ign () then
@@ -2512,7 +2512,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
     if not legacy_behavior then begin
     if not !plus_used && plus then
       incompatible_flag pct_ind str_ind symb "'+'";
-    if not !sharp_used && sharp then
+    if not !hash_used && hash then
       incompatible_flag pct_ind str_ind symb "'#'";
     if not !space_used && space then
       incompatible_flag pct_ind str_ind symb "' '";
@@ -2858,8 +2858,8 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | 'L' -> Token_counter | _ -> assert false
 
   (* Convert (plus, symb) to its associated int_conv. *)
-  and compute_int_conv pct_ind str_ind plus sharp space symb =
-    match plus, sharp, space, symb with
+  and compute_int_conv pct_ind str_ind plus hash space symb =
+    match plus, hash, space, symb with
     | false, false, false, 'd' -> Int_d  | false, false, false, 'i' -> Int_i
     | false, false,  true, 'd' -> Int_sd | false, false,  true, 'i' -> Int_si
     |  true, false, false, 'd' -> Int_pd |  true, false, false, 'i' -> Int_pi
@@ -2878,15 +2878,15 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | true, _, true, _ ->
       if legacy_behavior then
         (* plus and space: legacy implementation prefers plus *)
-        compute_int_conv pct_ind str_ind plus sharp false symb
+        compute_int_conv pct_ind str_ind plus hash false symb
       else incompatible_flag pct_ind str_ind ' ' "'+'"
     | false, _, true, _    ->
       if legacy_behavior then (* ignore *)
-        compute_int_conv pct_ind str_ind plus sharp false symb
+        compute_int_conv pct_ind str_ind plus hash false symb
       else incompatible_flag pct_ind str_ind symb "' '"
     | true, _, false, _    ->
       if legacy_behavior then (* ignore *)
-        compute_int_conv pct_ind str_ind false sharp space symb
+        compute_int_conv pct_ind str_ind false hash space symb
       else incompatible_flag pct_ind str_ind symb "'+'"
     | false, _, false, _ -> assert false
 

diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml
index 539868e7de1468355b4b2631ebda79480331b8bb..9dbd563d7a9e8da4172509ecd2cf2bcd8feb90d5 100644 (file)
--- a/stdlib/camlinternalFormatBasics.ml
+++ b/stdlib/camlinternalFormatBasics.ml
@@ -540,7 +540,7 @@ let rec erase_rel : type a b c d e f g h i j k l .
     Bool_ty (erase_rel rest)
   | Format_arg_ty (ty, rest) ->
     Format_arg_ty (ty, erase_rel rest)
-  | Format_subst_ty (ty1, ty2, rest) ->
+  | Format_subst_ty (ty1, _ty2, rest) ->
     Format_subst_ty (ty1, ty1, erase_rel rest)
   | Alpha_ty rest ->
     Alpha_ty (erase_rel rest)

diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml
index ea477e31d95167767acaaa13e0b0a0448ad328c4..9e2619263e09ffd4e5a9a3ef615415910e416074 100644 (file)
--- a/stdlib/camlinternalMod.ml
+++ b/stdlib/camlinternalMod.ml
@@ -71,4 +71,4 @@ let rec update_mod shape o n =
       for i = 0 to Array.length comps - 1 do
         update_mod comps.(i) (Obj.field o i) (Obj.field n i)
       done
-  | Value v -> () (* the value is already there *)
+  | Value _ -> () (* the value is already there *)

diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 0e296890dc01a5efe258c4c5dad5f31ae686ed1f..0188c148cd2d80b300e1aedd97ee6567ac64ecd9 100644 (file)
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -457,20 +457,20 @@ let lookup_tables root keys =
 
 (**** builtin methods ****)
 
-let get_const x = ret (fun obj -> x)
+let get_const x = ret (fun _obj -> x)
 let get_var n   = ret (fun obj -> Array.unsafe_get obj n)
 let get_env e n =
   ret (fun obj ->
     Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n)
 let get_meth n  = ret (fun obj -> sendself obj n)
 let set_var n   = ret (fun obj x -> Array.unsafe_set obj n x)
-let app_const f x = ret (fun obj -> f x)
+let app_const f x = ret (fun _obj -> f x)
 let app_var f n   = ret (fun obj -> f (Array.unsafe_get obj n))
 let app_env f e n =
   ret (fun obj ->
     f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n))
 let app_meth f n  = ret (fun obj -> f (sendself obj n))
-let app_const_const f x y = ret (fun obj -> f x y)
+let app_const_const f x y = ret (fun _obj -> f x y)
 let app_const_var f x n   = ret (fun obj -> f x (Array.unsafe_get obj n))
 let app_const_meth f x n = ret (fun obj -> f x (sendself obj n))
 let app_var_const f n x = ret (fun obj -> f (Array.unsafe_get obj n) x)

diff --git a/stdlib/char.ml b/stdlib/char.ml
index f3769b74a7984868cf09b021bceea59b4b04f493..fb7660d0776c2ff2bbc874147c0dde23ffbab5ab 100644 (file)
--- a/stdlib/char.ml
+++ b/stdlib/char.ml
@@ -21,9 +21,10 @@ external unsafe_chr: int -> char = "%identity"
 let chr n =
   if n < 0 || n > 255 then invalid_arg "Char.chr" else unsafe_chr n
 
-external string_create: int -> string = "caml_create_string"
-external string_unsafe_set : string -> int -> char -> unit
-                           = "%string_unsafe_set"
+external bytes_create: int -> bytes = "caml_create_bytes"
+external bytes_unsafe_set : bytes -> int -> char -> unit
+                           = "%bytes_unsafe_set"
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
 
 let escaped = function
   | '\'' -> "\\'"
@@ -33,17 +34,17 @@ let escaped = function
   | '\r' -> "\\r"
   | '\b' -> "\\b"
   | ' ' .. '~' as c ->
-      let s = string_create 1 in
-      string_unsafe_set s 0 c;
-      s
+      let s = bytes_create 1 in
+      bytes_unsafe_set s 0 c;
+      unsafe_to_string s
   | c ->
       let n = code c in
-      let s = string_create 4 in
-      string_unsafe_set s 0 '\\';
-      string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
-      string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
-      string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
-      s
+      let s = bytes_create 4 in
+      bytes_unsafe_set s 0 '\\';
+      bytes_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+      bytes_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+      bytes_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+      unsafe_to_string s
 
 let lowercase c =
   if (c >= 'A' && c <= 'Z')

diff --git a/stdlib/ephemeron.ml b/stdlib/ephemeron.ml
index 5cec32843ba62c7d285cb5ab617dc3826ae379ac..64b2529aea2cc8aba3a224013f09c594cd8659cc 100644 (file)
--- a/stdlib/ephemeron.ml
+++ b/stdlib/ephemeron.ml
@@ -189,7 +189,7 @@ module GenHashTable = struct
               begin match H.get_data c with
               | None ->
                   (* This case is not impossible because the gc can run between
-                     H.equal and H.get_data *)
+                      H.equal and H.get_data *)
                   find_rec key hkey rest
               | Some d -> d
               end
@@ -256,7 +256,7 @@ module GenHashTable = struct
           | ETrue -> true
           | EFalse | EDead -> mem_in_bucket rest
           end
-      | Cons(hk, c, rest) -> mem_in_bucket rest in
+      | Cons(_hk, _c, rest) -> mem_in_bucket rest in
       mem_in_bucket h.data.(key_index h hkey)
 
     let iter f h =
@@ -402,7 +402,7 @@ module K1 = struct
       let hash = H.hash
       let equal c k =
         (* {!get_key_copy} is not used because the equality of the user can be
-           the physical equality *)
+            the physical equality *)
         match get_key c with
         | None -> GenHashTable.EDead
         | Some k' ->
@@ -421,7 +421,7 @@ module K1 = struct
     include MakeSeeded(struct
         type t = H.t
         let equal = H.equal
-        let hash (seed: int) x = H.hash x
+        let hash (_seed: int) x = H.hash x
       end)
     let create sz = create ~random:false sz
   end
@@ -504,12 +504,12 @@ module K2 = struct
         (struct
           type t = H1.t
           let equal = H1.equal
-          let hash (seed: int) x = H1.hash x
+          let hash (_seed: int) x = H1.hash x
         end)
         (struct
           type t = H2.t
           let equal = H2.equal
-          let hash (seed: int) x = H2.hash x
+          let hash (_seed: int) x = H2.hash x
         end)
     let create sz = create ~random:false sz
   end
@@ -609,7 +609,7 @@ module Kn = struct
     include MakeSeeded(struct
         type t = H.t
         let equal = H.equal
-        let hash (seed: int) x = H.hash x
+        let hash (_seed: int) x = H.hash x
       end)
     let create sz = create ~random:false sz
   end

diff --git a/stdlib/ephemeron.mli b/stdlib/ephemeron.mli
index 1d931192c3de687dc26db4f327d861bb90e95683..a05306bf692eafc207e255b8541b0947415e6946 100644 (file)
--- a/stdlib/ephemeron.mli
+++ b/stdlib/ephemeron.mli
@@ -44,7 +44,7 @@
     full keys are alive and if the ephemeron is alive. When one of the
     keys is not considered alive anymore by the GC, the data is
     emptied from the ephemeron. The data could be alive for another
-    reason and in that case the GC will free it, but the ephemeron
+    reason and in that case the GC will not free it, but the ephemeron
     will not hold the data anymore.
 
     The ephemerons complicate the notion of liveness of values, because
@@ -222,13 +222,13 @@ module K2 : sig
   val check_key2: ('k1,'k2,'d) t -> bool
   (** Same as {!Ephemeron.K1.check_key} *)
 
-  val blit_key1  : ('k1,_,_) t -> ('k1,_,_) t -> unit
+  val blit_key1: ('k1,_,_) t -> ('k1,_,_) t -> unit
   (** Same as {!Ephemeron.K1.blit_key} *)
 
-  val blit_key2  : (_,'k2,_) t -> (_,'k2,_) t -> unit
+  val blit_key2: (_,'k2,_) t -> (_,'k2,_) t -> unit
   (** Same as {!Ephemeron.K1.blit_key} *)
 
-  val blit_key12 : ('k1,'k2,_) t -> ('k1,'k2,_) t -> unit
+  val blit_key12: ('k1,'k2,_) t -> ('k1,'k2,_) t -> unit
   (** Same as {!Ephemeron.K1.blit_key} *)
 
   val get_data: ('k1,'k2,'d) t -> 'd option
@@ -286,7 +286,7 @@ module Kn : sig
   val check_key: ('k,'d) t -> int ->  bool
   (** Same as {!Ephemeron.K1.check_key} *)
 
-  val blit_key  : ('k,_) t -> int -> ('k,_) t -> int -> int -> unit
+  val blit_key: ('k,_) t -> int -> ('k,_) t -> int -> int -> unit
   (** Same as {!Ephemeron.K1.blit_key} *)
 
   val get_data: ('k,'d) t -> 'd option

diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index 3e727fba4daf976298e54a057ad5c4d1e1b0ccf9..f9b0bc6c4677c5fcc7c214c3f837b29b0f0396e9 100644 (file)
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -130,7 +130,7 @@ module Win32 = struct
         match s.[i] with
         | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1);
         | '\\' -> loop_bs (n+1) (i+1);
-        | c    -> add_bs n; loop i
+        | _    -> add_bs n; loop i
       end
     and add_bs n = for _j = 1 to n do Buffer.add_char b '\\'; done
     in
@@ -151,7 +151,7 @@ module Win32 = struct
     let dir = generic_dirname is_dir_sep current_dir_name path in
     drive ^ dir
   let basename s =
-    let (drive, path) = drive_and_path s in
+    let (_drive, path) = drive_and_path s in
     generic_basename is_dir_sep current_dir_name path
 end
 
@@ -173,11 +173,6 @@ let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
      is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
      dirname) =
   match Sys.os_type with
-    "Unix" ->
-      (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
-       Unix.is_dir_sep,
-       Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
-       Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
   | "Win32" ->
       (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
        Win32.is_dir_sep,
@@ -188,7 +183,11 @@ let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
        Cygwin.is_dir_sep,
        Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
        Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
-  | _ -> assert false
+  | _ -> (* normally "Unix" *)
+      (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
+       Unix.is_dir_sep,
+       Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
+       Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
 
 let concat dirname filename =
   let l = String.length dirname in
@@ -200,13 +199,32 @@ let chop_suffix name suff =
   let n = String.length name - String.length suff in
   if n < 0 then invalid_arg "Filename.chop_suffix" else String.sub name 0 n
 
-let chop_extension name =
+let extension_len name =
+  let rec check i0 i =
+    if i < 0 || is_dir_sep name i then 0
+    else if name.[i] = '.' then check i0 (i - 1)
+    else String.length name - i0
+  in
   let rec search_dot i =
-    if i < 0 || is_dir_sep name i then invalid_arg "Filename.chop_extension"
-    else if name.[i] = '.' then String.sub name 0 i
-    else search_dot (i - 1) in
+    if i < 0 || is_dir_sep name i then 0
+    else if name.[i] = '.' then check i (i - 1)
+    else search_dot (i - 1)
+  in
   search_dot (String.length name - 1)
 
+let extension name =
+  let l = extension_len name in
+  if l = 0 then "" else String.sub name (String.length name - l) l
+
+let chop_extension name =
+  let l = extension_len name in
+  if l = 0 then invalid_arg "Filename.chop_extension"
+  else String.sub name 0 (String.length name - l)
+
+let remove_extension name =
+  let l = extension_len name in
+  if l = 0 then name else String.sub name 0 (String.length name - l)
+
 external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
 external close_desc: int -> unit = "caml_sys_close"
 

diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index b5d11c3d34308a911fdf38a3471ff234a0318a09..fa6f0369893078a367e394cd4678543905689a86 100644 (file)
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -49,13 +49,37 @@ val chop_suffix : string -> string -> string
    the filename [name]. The behavior is undefined if [name] does not
    end with the suffix [suff]. *)
 
+val extension : string -> string
+(** [extension name] is the shortest suffix [ext] of [name0] where:
+
+    - [name0] is the longest suffix of [name] that does not
+      contain a directory separator;
+    - [ext] starts with a period;
+    - [ext] is preceded by at least one non-period character
+      in [name0].
+
+    If such a suffix does not exist, [extension name] is the empty
+    string.
+
+    @since 4.04
+*)
+
+val remove_extension : string -> string
+(** Return the given file name without its extension, as defined
+    in {!Filename.extension}. If the extension is empty, the function
+    returns the given file name.
+
+    The following invariant holds for any file name [s]:
+
+    [remove_extension s ^ extension s = s]
+
+    @since 4.04
+*)
+
 val chop_extension : string -> string
-(** Return the given file name without its extension. The extension
-   is the shortest suffix starting with a period and not including
-   a directory separator, [.xyz] for instance.
+(** Same as {!Filename.remove_extension}, but raise [Invalid_argument]
+    if the given name has an empty extension. *)
 
-   Raise [Invalid_argument] if the given name does not contain
-   an extension. *)
 
 val basename : string -> string
 (** Split a file name into directory name / base file name.

diff --git a/stdlib/format.ml b/stdlib/format.ml
index 488b0a09d9c8b5b1ee21d27a502acf036c90c894..8caa18f5a36824d38bb1ab59ed5576b2f66a7349 100644 (file)
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -83,12 +83,10 @@ and tbox = Pp_tbox of int list ref  (* Tabulation box *)
 (* The pretty-printer queue: polymorphic queue definition. *)
 type 'a queue_elem =
   | Nil
-  | Cons of 'a queue_cell
-
-and 'a queue_cell = {
-  mutable head : 'a;
-  mutable tail : 'a queue_elem;
-}
+  | Cons of {
+      head : 'a;
+      mutable tail : 'a queue_elem;
+    }
 
 
 type 'a queue = {
@@ -898,6 +896,9 @@ let pp_get_formatter_output_functions state () =
   (state.pp_out_string, state.pp_out_flush)
 
 
+let pp_flush_formatter state =
+  pp_flush_queue state false
+
 (* The default function to output new lines. *)
 let display_newline state () = state.pp_out_string "\n" 0  1
 

diff --git a/stdlib/format.mli b/stdlib/format.mli
index 1278d358fc88484344cb26016564d9327081efc9..2f52dbe601db1a3988a5fc057a742e9bc2a88785 100644 (file)
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -271,13 +271,13 @@ val set_ellipsis_text : string -> unit
 val get_ellipsis_text : unit -> string
 (** Return the text of the ellipsis. *)
 
-(** {6:tags Semantics Tags} *)
+(** {6:tags Semantic Tags} *)
 
 type tag = string
 
-(** {i Semantics tags} (or simply {e tags}) are used to decorate printed
+(** {i Semantic tags} (or simply {e tags}) are used to decorate printed
   entities for user's defined purposes, e.g. setting font and giving size
-  indications for a display device, or marking delimitation of semantics
+  indications for a display device, or marking delimitation of semantic
   entities (e.g. HTML or TeX elements or terminal escape sequences).
 
   By default, those tags do not influence line splitting calculation:
@@ -310,7 +310,7 @@ type tag = string
   corresponding to tag markers is considered as zero for line
   splitting). In addition, advanced users may take advantage of
   the specificity of tag markers to be precisely output when the
-  pretty printer has already decided where to splitt the lines, and
+  pretty printer has already decided where to split the lines, and
   precisely when the queue is flushed into the output device.
 
   In the spirit of HTML tags, the default tag marking functions
@@ -411,7 +411,7 @@ val get_formatter_out_functions : unit -> formatter_out_functions
   including line splitting and indentation functions. Useful to record the
   current setting and restore it afterwards. *)
 
-(** {6:tagsmeaning Changing the meaning of printing semantics tags} *)
+(** {6:tagsmeaning Changing the meaning of printing semantic tags} *)
 
 type formatter_tag_functions = {
   mark_open_tag : tag -> string;
@@ -565,6 +565,14 @@ val pp_get_formatter_out_functions :
    evaluation of these primitives. For instance,
    [print_string] is equal to [pp_print_string std_formatter]. *)
 
+val pp_flush_formatter : formatter -> unit
+(** [pp_flush_formatter fmt] flushes [fmt]'s internal queue, ensuring that all
+    the printing and flushing actions have been performed. In addition, this
+    operation will close all boxes and reset the state of the formatter.
+
+    This will not flush [fmt]'s output. In most cases, the user may want to use
+    {!pp_print_flush} instead. *)
+
 (** {6 Convenience formatting functions.} *)
 
 val pp_print_list:

diff --git a/stdlib/gc.ml b/stdlib/gc.ml
index 5635f438f3b656435adf0170d7711743a044e259..fc04b6064546609450ade0742309ee311d664457 100644 (file)
--- a/stdlib/gc.ml
+++ b/stdlib/gc.ml
@@ -46,6 +46,8 @@ type control = {
 external stat : unit -> stat = "caml_gc_stat"
 external quick_stat : unit -> stat = "caml_gc_quick_stat"
 external counters : unit -> (float * float * float) = "caml_gc_counters"
+external minor_words : unit -> (float [@unboxed])
+  = "caml_gc_minor_words" "caml_gc_minor_words_unboxed" [@@noalloc]
 external get : unit -> control = "caml_gc_get"
 external set : control -> unit = "caml_gc_set"
 external minor : unit -> unit = "caml_gc_minor"
@@ -90,6 +92,8 @@ let allocated_bytes () =
 
 
 external finalise : ('a -> unit) -> 'a -> unit = "caml_final_register"
+external finalise_last : (unit -> unit) -> 'a -> unit =
+  "caml_final_register_called_without_value"
 external finalise_release : unit -> unit = "caml_final_release"
 
 

diff --git a/stdlib/gc.mli b/stdlib/gc.mli
index 4a6d12c32f42a0457cdeea0cf3518229117f1747..5a1e62724fd9468a375b46a31a6dec6ed52d4022 100644 (file)
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -170,6 +170,16 @@ external counters : unit -> float * float * float = "caml_gc_counters"
 (** Return [(minor_words, promoted_words, major_words)].  This function
     is as fast as [quick_stat]. *)
 
+external minor_words : unit -> (float [@unboxed])
+  = "caml_gc_minor_words" "caml_gc_minor_words_unboxed" [@@noalloc]
+(** Number of words allocated in the minor heap since the program was
+    started. This number is accurate in byte-code programs, but only an
+    approximation in programs compiled to native code.
+
+    In native code this function does not allocate.
+
+    @since 4.04 *)
+
 external get : unit -> control = "caml_gc_get"
 (** Return the current values of the GC parameters in a [control] record. *)
 
@@ -210,18 +220,24 @@ val allocated_bytes : unit -> float
    with [int] on 32-bit machines. *)
 
 external get_minor_free : unit -> int = "caml_get_minor_free" [@@noalloc]
-(** Return the current size of the free space inside the minor heap. *)
+(** Return the current size of the free space inside the minor heap.
+
+    @since 4.03.0 *)
 
 external get_bucket : int -> int = "caml_get_major_bucket" [@@noalloc]
 (** [get_bucket n] returns the current size of the [n]-th future bucket
     of the GC smoothing system. The unit is one millionth of a full GC.
     Raise [Invalid_argument] if [n] is negative, return 0 if n is larger
-    than the smoothing window. *)
+    than the smoothing window.
+
+    @since 4.03.0 *)
 
 external get_credit : unit -> int = "caml_get_major_credit" [@@noalloc]
 (** [get_credit ()] returns the current size of the "work done in advance"
     counter of the GC smoothing system. The unit is one millionth of a
-    full GC. *)
+    full GC.
+
+    @since 4.03.0 *)
 
 external huge_fallback_count : unit -> int = "caml_gc_huge_fallback_count"
 (** Return the number of times we tried to map huge pages and had to fall
@@ -279,9 +295,14 @@ val finalise : ('a -> unit) -> 'a -> unit
    Some constant values can be heap-allocated but never deallocated
    during the lifetime of the program, for example a list of integer
    constants; this is also implementation-dependent.
-   Note that values of types [float] and ['a lazy] (for any ['a]) are
-   sometimes allocated and sometimes not, so finalising them is unsafe,
-   and [finalise] will also raise [Invalid_argument] for them.
+   Note that values of types [float] are sometimes allocated and
+   sometimes not, so finalising them is unsafe, and [finalise] will
+   also raise [Invalid_argument] for them. Values of type ['a Lazy.t]
+   (for any ['a]) are like [float] in this respect, except that the
+   compiler sometimes optimizes them in a way that prevents [finalise]
+   from detecting them. In this case, it will not raise
+   [Invalid_argument], but you should still avoid calling [finalise]
+   on lazy values.
 
 
    The results of calling {!String.make}, {!Bytes.make}, {!Bytes.create},
@@ -289,6 +310,21 @@ val finalise : ('a -> unit) -> 'a -> unit
    heap-allocated and non-constant except when the length argument is [0].
 *)
 
+val finalise_last : (unit -> unit) -> 'a -> unit
+(** same as {!finalise} except the value is not given as argument. So
+    you can't use the given value for the computation of the
+    finalisation function. The benefit is that the function is called
+    after the value is unreachable for the last time instead of the
+    first time. So contrary to {!finalise} the value will never be
+    reachable again or used again. In particular every weak pointer
+    and ephemeron that contained this value as key or data is unset
+    before running the finalisation function. Moreover the
+    finalisation function attached with `GC.finalise` are always
+    called before the finalisation function attached with `GC.finalise_last`.
+
+    @since 4.04
+*)
+
 val finalise_release : unit -> unit
 (** A finalisation function may call [finalise_release] to tell the
     GC that it can launch the next finalisation function without waiting

diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml
index a5e34f4ea555d9957cd2112567e3c700ea83b0b6..b015bb95aa722f370754c6a7f5b2d4bd136ef935 100644 (file)
--- a/stdlib/genlex.ml
+++ b/stdlib/genlex.ml
@@ -184,18 +184,18 @@ let make_lexer keywords =
     match Stream.peek strm__ with
       Some '(' -> Stream.junk strm__; maybe_nested_comment strm__
     | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
-    | Some c -> Stream.junk strm__; comment strm__
+    | Some _ -> Stream.junk strm__; comment strm__
     | _ -> raise Stream.Failure
   and maybe_nested_comment (strm__ : _ Stream.t) =
     match Stream.peek strm__ with
       Some '*' -> Stream.junk strm__; let s = strm__ in comment s; comment s
-    | Some c -> Stream.junk strm__; comment strm__
+    | Some _ -> Stream.junk strm__; comment strm__
     | _ -> raise Stream.Failure
   and maybe_end_comment (strm__ : _ Stream.t) =
     match Stream.peek strm__ with
       Some ')' -> Stream.junk strm__; ()
     | Some '*' -> Stream.junk strm__; maybe_end_comment strm__
-    | Some c -> Stream.junk strm__; comment strm__
+    | Some _ -> Stream.junk strm__; comment strm__
     | _ -> raise Stream.Failure
   in
-  fun input -> Stream.from (fun count -> next_token input)
+  fun input -> Stream.from (fun _count -> next_token input)

diff --git a/stdlib/hashbang b/stdlib/hashbang
new file mode 100644 (file)
index 0000000..04c9334
--- /dev/null
+++ b/stdlib/hashbang
@@ -0,0 +1 @@
+#! 
\ No newline at end of file

diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index 955f63845d08ec75fd5ff1348a633be521c659ab..58e558e2060be09930370763efa85dd433376dc6 100644 (file)
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -31,12 +31,27 @@ type ('a, 'b) t =
   { mutable size: int;                        (* number of entries *)
     mutable data: ('a, 'b) bucketlist array;  (* the buckets *)
     mutable seed: int;                        (* for randomization *)
-    initial_size: int;                        (* initial array size *)
+    mutable initial_size: int;                (* initial array size *)
   }
 
 and ('a, 'b) bucketlist =
     Empty
-  | Cons of 'a * 'b * ('a, 'b) bucketlist
+  | Cons of { mutable key: 'a;
+              mutable data: 'b;
+              mutable next: ('a, 'b) bucketlist }
+
+(* The sign of initial_size encodes the fact that a traversal is
+   ongoing or not.
+
+   This disables the efficient in place implementation of resizing.
+*)
+
+let ongoing_traversal h =
+  Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
+  || h.initial_size < 0
+
+let flip_ongoing_traversal h =
+  h.initial_size <- - h.initial_size
 
 (* To pick random seeds if requested *)
 
@@ -75,14 +90,31 @@ let clear h =
 let reset h =
   let len = Array.length h.data in
   if Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
-    || len = h.initial_size then
+    || len = abs h.initial_size then
     clear h
   else begin
     h.size <- 0;
-    h.data <- Array.make h.initial_size Empty
+    h.data <- Array.make (abs h.initial_size) Empty
   end
 
-let copy h = { h with data = Array.copy h.data }
+let copy_bucketlist = function
+  | Empty -> Empty
+  | Cons {key; data; next} ->
+      let rec loop prec = function
+        | Empty -> ()
+        | Cons {key; data; next} ->
+            let r = Cons {key; data; next} in
+            begin match prec with
+            | Empty -> assert false
+            | Cons prec ->  prec.next <- r
+            end;
+            loop r next
+      in
+      let r = Cons {key; data; next} in
+      loop r next;
+      r
+
+let copy h = { h with data = Array.map copy_bucketlist h.data }
 
 let length h = h.size
 
@@ -92,16 +124,33 @@ let resize indexfun h =
   let nsize = osize * 2 in
   if nsize < Sys.max_array_length then begin
     let ndata = Array.make nsize Empty in
+    let ndata_tail = Array.make nsize Empty in
+    let inplace = not (ongoing_traversal h) in
     h.data <- ndata;          (* so that indexfun sees the new bucket count *)
     let rec insert_bucket = function
-        Empty -> ()
-      | Cons(key, data, rest) ->
-          insert_bucket rest; (* preserve original order of elements *)
+      | Empty -> ()
+      | Cons {key; data; next} as cell ->
+          let cell =
+            if inplace then cell
+            else Cons {key; data; next = Empty}
+          in
           let nidx = indexfun h key in
-          ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
+          begin match ndata_tail.(nidx) with
+          | Empty -> ndata.(nidx) <- cell;
+          | Cons tail -> tail.next <- cell;
+          end;
+          ndata_tail.(nidx) <- cell;
+          insert_bucket next
+    in
     for i = 0 to osize - 1 do
       insert_bucket odata.(i)
-    done
+    done;
+    if inplace then
+      for i = 0 to nsize - 1 do
+        match ndata_tail.(i) with
+        | Empty -> ()
+        | Cons tail -> tail.next <- Empty
+      done;
   end
 
 let key_index h key =
@@ -110,117 +159,155 @@ let key_index h key =
   then (seeded_hash_param 10 100 h.seed key) land (Array.length h.data - 1)
   else (old_hash_param 10 100 key) mod (Array.length h.data)
 
-let add h key info =
+let add h key data =
   let i = key_index h key in
-  let bucket = Cons(key, info, h.data.(i)) in
+  let bucket = Cons{key; data; next=h.data.(i)} in
   h.data.(i) <- bucket;
   h.size <- h.size + 1;
   if h.size > Array.length h.data lsl 1 then resize key_index h
 
+let rec remove_bucket h i key prec = function
+  | Empty ->
+      ()
+  | (Cons {key=k; next}) as c ->
+      if compare k key = 0
+      then begin
+        h.size <- h.size - 1;
+        match prec with
+        | Empty -> h.data.(i) <- next
+        | Cons c -> c.next <- next
+      end
+      else remove_bucket h i key c next
+
 let remove h key =
-  let rec remove_bucket = function
-    | Empty ->
-        Empty
-    | Cons(k, i, next) ->
-        if compare k key = 0
-        then begin h.size <- h.size - 1; next end
-        else Cons(k, i, remove_bucket next) in
   let i = key_index h key in
-  h.data.(i) <- remove_bucket h.data.(i)
+  remove_bucket h i key Empty h.data.(i)
 
 let rec find_rec key = function
   | Empty ->
       raise Not_found
-  | Cons(k, d, rest) ->
-      if compare key k = 0 then d else find_rec key rest
+  | Cons{key=k; data; next} ->
+      if compare key k = 0 then data else find_rec key next
 
 let find h key =
   match h.data.(key_index h key) with
   | Empty -> raise Not_found
-  | Cons(k1, d1, rest1) ->
+  | Cons{key=k1; data=d1; next=next1} ->
       if compare key k1 = 0 then d1 else
-      match rest1 with
+      match next1 with
       | Empty -> raise Not_found
-      | Cons(k2, d2, rest2) ->
+      | Cons{key=k2; data=d2; next=next2} ->
           if compare key k2 = 0 then d2 else
-          match rest2 with
+          match next2 with
           | Empty -> raise Not_found
-          | Cons(k3, d3, rest3) ->
-              if compare key k3 = 0 then d3 else find_rec key rest3
+          | Cons{key=k3; data=d3; next=next3} ->
+              if compare key k3 = 0 then d3 else find_rec key next3
 
 let find_all h key =
   let rec find_in_bucket = function
   | Empty ->
       []
-  | Cons(k, d, rest) ->
+  | Cons{key=k; data; next} ->
       if compare k key = 0
-      then d :: find_in_bucket rest
-      else find_in_bucket rest in
+      then data :: find_in_bucket next
+      else find_in_bucket next in
   find_in_bucket h.data.(key_index h key)
 
-let replace h key info =
-  let rec replace_bucket = function
-    | Empty ->
-        raise_notrace Not_found
-    | Cons(k, i, next) ->
-        if compare k key = 0
-        then Cons(key, info, next)
-        else Cons(k, i, replace_bucket next) in
+let rec replace_bucket key data = function
+  | Empty ->
+      true
+  | Cons ({key=k; next} as slot) ->
+      if compare k key = 0
+      then (slot.key <- key; slot.data <- data; false)
+      else replace_bucket key data next
+
+let replace h key data =
   let i = key_index h key in
   let l = h.data.(i) in
-  try
-    h.data.(i) <- replace_bucket l
-  with Not_found ->
-    h.data.(i) <- Cons(key, info, l);
+  if replace_bucket key data l then begin
+    h.data.(i) <- Cons{key; data; next=l};
     h.size <- h.size + 1;
     if h.size > Array.length h.data lsl 1 then resize key_index h
+  end
 
 let mem h key =
   let rec mem_in_bucket = function
   | Empty ->
       false
-  | Cons(k, d, rest) ->
-      compare k key = 0 || mem_in_bucket rest in
+  | Cons{key=k; next} ->
+      compare k key = 0 || mem_in_bucket next in
   mem_in_bucket h.data.(key_index h key)
 
 let iter f h =
   let rec do_bucket = function
     | Empty ->
         ()
-    | Cons(k, d, rest) ->
-        f k d; do_bucket rest in
-  let d = h.data in
-  for i = 0 to Array.length d - 1 do
-    do_bucket d.(i)
-  done
+    | Cons{key; data; next} ->
+        f key data; do_bucket next in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    let d = h.data in
+    for i = 0 to Array.length d - 1 do
+      do_bucket d.(i)
+    done;
+    if not old_trav then flip_ongoing_traversal h;
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
+
+let rec filter_map_inplace_bucket f h i prec = function
+  | Empty ->
+      begin match prec with
+      | Empty -> h.data.(i) <- Empty
+      | Cons c -> c.next <- Empty
+      end
+  | (Cons ({key; data; next} as c)) as slot ->
+      begin match f key data with
+      | None ->
+          h.size <- h.size - 1;
+          filter_map_inplace_bucket f h i prec next
+      | Some data ->
+          begin match prec with
+          | Empty -> h.data.(i) <- slot
+          | Cons c -> c.next <- slot
+          end;
+          c.data <- data;
+          filter_map_inplace_bucket f h i slot next
+      end
 
 let filter_map_inplace f h =
-  let rec do_bucket = function
-    | Empty ->
-        Empty
-    | Cons(k, d, rest) ->
-        match f k d with
-        | None -> h.size <- h.size - 1; do_bucket rest
-        | Some new_d -> Cons(k, new_d, do_bucket rest)
-  in
   let d = h.data in
-  for i = 0 to Array.length d - 1 do
-    d.(i) <- do_bucket d.(i)
-  done
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    for i = 0 to Array.length d - 1 do
+      filter_map_inplace_bucket f h i Empty h.data.(i)
+    done
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
 
 let fold f h init =
   let rec do_bucket b accu =
     match b with
       Empty ->
         accu
-    | Cons(k, d, rest) ->
-        do_bucket rest (f k d accu) in
-  let d = h.data in
-  let accu = ref init in
-  for i = 0 to Array.length d - 1 do
-    accu := do_bucket d.(i) !accu
-  done;
-  !accu
+    | Cons{key; data; next} ->
+        do_bucket next (f key data accu) in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    let d = h.data in
+    let accu = ref init in
+    for i = 0 to Array.length d - 1 do
+      accu := do_bucket d.(i) !accu
+    done;
+    if not old_trav then flip_ongoing_traversal h;
+    !accu
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
 
 type statistics = {
   num_bindings: int;
@@ -231,7 +318,7 @@ type statistics = {
 
 let rec bucket_length accu = function
   | Empty -> accu
-  | Cons(_, _, rest) -> bucket_length (accu + 1) rest
+  | Cons{next} -> bucket_length (accu + 1) next
 
 let stats h =
   let mbl =
@@ -318,77 +405,83 @@ module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) =
     let key_index h key =
       (H.hash h.seed key) land (Array.length h.data - 1)
 
-    let add h key info =
+    let add h key data =
       let i = key_index h key in
-      let bucket = Cons(key, info, h.data.(i)) in
+      let bucket = Cons{key; data; next=h.data.(i)} in
       h.data.(i) <- bucket;
       h.size <- h.size + 1;
       if h.size > Array.length h.data lsl 1 then resize key_index h
 
+    let rec remove_bucket h i key prec = function
+      | Empty ->
+          ()
+      | (Cons {key=k; next}) as c ->
+          if H.equal k key
+          then begin
+            h.size <- h.size - 1;
+            match prec with
+            | Empty -> h.data.(i) <- next
+            | Cons c -> c.next <- next
+          end
+          else remove_bucket h i key c next
+
     let remove h key =
-      let rec remove_bucket = function
-        | Empty ->
-            Empty
-        | Cons(k, i, next) ->
-            if H.equal k key
-            then begin h.size <- h.size - 1; next end
-            else Cons(k, i, remove_bucket next) in
       let i = key_index h key in
-      h.data.(i) <- remove_bucket h.data.(i)
+      remove_bucket h i key Empty h.data.(i)
 
     let rec find_rec key = function
       | Empty ->
           raise Not_found
-      | Cons(k, d, rest) ->
-          if H.equal key k then d else find_rec key rest
+      | Cons{key=k; data; next} ->
+          if H.equal key k then data else find_rec key next
 
     let find h key =
       match h.data.(key_index h key) with
       | Empty -> raise Not_found
-      | Cons(k1, d1, rest1) ->
+      | Cons{key=k1; data=d1; next=next1} ->
           if H.equal key k1 then d1 else
-          match rest1 with
+          match next1 with
           | Empty -> raise Not_found
-          | Cons(k2, d2, rest2) ->
+          | Cons{key=k2; data=d2; next=next2} ->
               if H.equal key k2 then d2 else
-              match rest2 with
+              match next2 with
               | Empty -> raise Not_found
-              | Cons(k3, d3, rest3) ->
-                  if H.equal key k3 then d3 else find_rec key rest3
+              | Cons{key=k3; data=d3; next=next3} ->
+                  if H.equal key k3 then d3 else find_rec key next3
 
     let find_all h key =
       let rec find_in_bucket = function
       | Empty ->
           []
-      | Cons(k, d, rest) ->
+      | Cons{key=k; data=d; next} ->
           if H.equal k key
-          then d :: find_in_bucket rest
-          else find_in_bucket rest in
+          then d :: find_in_bucket next
+          else find_in_bucket next in
       find_in_bucket h.data.(key_index h key)
 
-    let replace h key info =
-      let rec replace_bucket = function
-        | Empty ->
-            raise_notrace Not_found
-        | Cons(k, i, next) ->
-            if H.equal k key
-            then Cons(key, info, next)
-            else Cons(k, i, replace_bucket next) in
+    let rec replace_bucket key data = function
+      | Empty ->
+          true
+      | Cons ({key=k; next} as slot) ->
+          if H.equal k key
+          then (slot.key <- key; slot.data <- data; false)
+          else replace_bucket key data next
+
+    let replace h key data =
       let i = key_index h key in
       let l = h.data.(i) in
-      try
-        h.data.(i) <- replace_bucket l
-      with Not_found ->
-        h.data.(i) <- Cons(key, info, l);
+      if replace_bucket key data l then begin
+        h.data.(i) <- Cons{key; data; next=l};
         h.size <- h.size + 1;
         if h.size > Array.length h.data lsl 1 then resize key_index h
+      end
 
     let mem h key =
       let rec mem_in_bucket = function
       | Empty ->
           false
-      | Cons(k, d, rest) ->
-          H.equal k key || mem_in_bucket rest in
+      | Cons{key=k; next} ->
+          H.equal k key || mem_in_bucket next in
       mem_in_bucket h.data.(key_index h key)
 
     let iter = iter
@@ -403,7 +496,7 @@ module Make(H: HashedType): (S with type key = H.t) =
     include MakeSeeded(struct
         type t = H.t
         let equal = H.equal
-        let hash (seed: int) x = H.hash x
+        let hash (_seed: int) x = H.hash x
       end)
     let create sz = create ~random:false sz
   end

diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index 96326ae8fbaf286665518475252c4ebdd9ab4b08..6d9cd00dd4b128a556d8631a92673a7057af369c 100644 (file)
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -135,7 +135,8 @@ val filter_map_inplace: ('a -> 'b -> 'b option) -> ('a, 'b) t -> unit
     returns [Some new_val], the binding is update to associate the key
     to [new_val].
 
-    Other comments for {!Hashtbl.iter} apply as well.  *)
+    Other comments for {!Hashtbl.iter} apply as well.
+    @since 4.03.0 *)
 
 val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
 (** [Hashtbl.fold f tbl init] computes
@@ -243,10 +244,10 @@ val stats : ('a, 'b) t -> statistics
 module type HashedType =
   sig
     type t
-      (** The type of the hashtable keys. *)
+    (** The type of the hashtable keys. *)
 
     val equal : t -> t -> bool
-      (** The equality predicate used to compare keys. *)
+    (** The equality predicate used to compare keys. *)
 
     val hash : t -> int
       (** A hashing function on keys. It must be such that if two keys are
@@ -301,10 +302,10 @@ module Make (H : HashedType) : S with type key = H.t
 module type SeededHashedType =
   sig
     type t
-      (** The type of the hashtable keys. *)
+    (** The type of the hashtable keys. *)
 
     val equal: t -> t -> bool
-      (** The equality predicate used to compare keys. *)
+    (** The equality predicate used to compare keys. *)
 
     val hash: int -> t -> int
       (** A seeded hashing function on keys.  The first argument is

diff --git a/stdlib/header.c b/stdlib/header.c
index 1fd4cd5eae14595237d5fb8562f083baf59e2601..28408a51360dbd145f926e62d16dff6ad95240dd 100644 (file)
--- a/stdlib/header.c
+++ b/stdlib/header.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /* The launcher for bytecode executables (if #! is not working) */
 
 #include <stdio.h>

diff --git a/stdlib/headernt.c b/stdlib/headernt.c
index d96747e545504d02b7effe87aa2ffdf522d43a70..9d4943b29eddeb6cc1a273c109c0685ab2aed0f2 100644 (file)
--- a/stdlib/headernt.c
+++ b/stdlib/headernt.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #define STRICT
 #define WIN32_LEAN_AND_MEAN
 

diff --git a/stdlib/list.ml b/stdlib/list.ml
index d969c57bb7c8721cc259eca87b815159a4bdf31e..c02f5e86a8ea867dd48146f4d0b81a664ae55c22 100644 (file)
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -17,7 +17,7 @@
 
 let rec length_aux len = function
     [] -> len
-  | a::l -> length_aux (len + 1) l
+  | _::l -> length_aux (len + 1) l
 
 let length l = length_aux 0 l
 
@@ -25,11 +25,11 @@ let cons a l = a::l
 
 let hd = function
     [] -> failwith "hd"
-  | a::l -> a
+  | a::_ -> a
 
 let tl = function
     [] -> failwith "tl"
-  | a::l -> l
+  | _::l -> l
 
 let nth l n =
   if n < 0 then invalid_arg "List.nth" else
@@ -164,20 +164,20 @@ let rec assq x = function
 
 let rec mem_assoc x = function
   | [] -> false
-  | (a, b) :: l -> compare a x = 0 || mem_assoc x l
+  | (a, _) :: l -> compare a x = 0 || mem_assoc x l
 
 let rec mem_assq x = function
   | [] -> false
-  | (a, b) :: l -> a == x || mem_assq x l
+  | (a, _) :: l -> a == x || mem_assq x l
 
 let rec remove_assoc x = function
   | [] -> []
-  | (a, b as pair) :: l ->
+  | (a, _ as pair) :: l ->
       if compare a x = 0 then l else pair :: remove_assoc x l
 
 let rec remove_assq x = function
   | [] -> []
-  | (a, b as pair) :: l -> if a == x then l else pair :: remove_assq x l
+  | (a, _ as pair) :: l -> if a == x then l else pair :: remove_assq x l
 
 let rec find p = function
   | [] -> raise Not_found
@@ -223,7 +223,7 @@ let rec merge cmp l1 l2 =
 let rec chop k l =
   if k = 0 then l else begin
     match l with
-    | x::t -> chop (k-1) t
+    | _::t -> chop (k-1) t
     | _ -> assert false
   end
 

diff --git a/stdlib/list.mli b/stdlib/list.mli
index 10ea358831adb5418294aa0ae1638bf47bdadcd6..7d12712a16aaaca0aa0cbd61e3899adb64adaa33 100644 (file)
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -67,8 +67,7 @@ val concat : 'a list list -> 'a list
    (length of the argument + length of the longest sub-list). *)
 
 val flatten : 'a list list -> 'a list
-(** Same as [concat].  Not tail-recursive
-   (length of the argument + length of the longest sub-list). *)
+(** An alias for [concat]. *)
 
 
 (** {6 Iterators} *)

diff --git a/stdlib/map.ml b/stdlib/map.ml
index 6f9293fc47b840b02f8b1e62b4a43b1c7149514e..50ebdb3dcfb965eb94277d4293e39c416324a3be 100644 (file)
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -128,23 +128,23 @@ module Make(Ord: OrderedType) = struct
     let rec mem x = function
         Empty ->
           false
-      | Node(l, v, d, r, _) ->
+      | Node(l, v, _, r, _) ->
           let c = Ord.compare x v in
           c = 0 || mem x (if c < 0 then l else r)
 
     let rec min_binding = function
         Empty -> raise Not_found
-      | Node(Empty, x, d, r, _) -> (x, d)
-      | Node(l, x, d, r, _) -> min_binding l
+      | Node(Empty, x, d, _, _) -> (x, d)
+      | Node(l, _, _, _, _) -> min_binding l
 
     let rec max_binding = function
         Empty -> raise Not_found
-      | Node(l, x, d, Empty, _) -> (x, d)
-      | Node(l, x, d, r, _) -> max_binding r
+      | Node(_, x, d, Empty, _) -> (x, d)
+      | Node(_, _, _, r, _) -> max_binding r
 
     let rec remove_min_binding = function
         Empty -> invalid_arg "Map.remove_min_elt"
-      | Node(Empty, x, d, r, _) -> r
+      | Node(Empty, _, _, r, _) -> r
       | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
 
     let merge t1 t2 =
@@ -158,7 +158,7 @@ module Make(Ord: OrderedType) = struct
     let rec remove x = function
         Empty ->
           Empty
-      | (Node(l, v, d, r, h) as t) ->
+      | (Node(l, v, d, r, _) as t) ->
           let c = Ord.compare x v in
           if c = 0 then merge l r
           else if c < 0 then
@@ -213,12 +213,12 @@ module Make(Ord: OrderedType) = struct
 
     let rec add_min_binding k v = function
       | Empty -> singleton k v
-      | Node (l, x, d, r, h) ->
+      | Node (l, x, d, r, _) ->
         bal (add_min_binding k v l) x d r
 
     let rec add_max_binding k v = function
       | Empty -> singleton k v
-      | Node (l, x, d, r, h) ->
+      | Node (l, x, d, r, _) ->
         bal l x d (add_max_binding k v r)
 
     (* Same as create and bal, but no assumptions are made on the
@@ -267,7 +267,7 @@ module Make(Ord: OrderedType) = struct
       | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
           let (l2, d2, r2) = split v1 s2 in
           concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
-      | (_, Node (l2, v2, d2, r2, h2)) ->
+      | (_, Node (l2, v2, d2, r2, _)) ->
           let (l1, d1, r1) = split v2 s1 in
           concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
       | _ ->

diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
index 220cf384f93712e50099ea4e069324de8953df9f..671feed7998347d9365fa2811b43dd7059279dfa 100644 (file)
--- a/stdlib/marshal.mli
+++ b/stdlib/marshal.mli
@@ -137,7 +137,12 @@ val from_channel : in_channel -> 'a
 (** [Marshal.from_channel chan] reads from channel [chan] the
    byte representation of a structured value, as produced by
    one of the [Marshal.to_*] functions, and reconstructs and
-   returns the corresponding value.*)
+   returns the corresponding value.
+
+   It raises [End_of_file] if the function has already reached the
+   end of file when starting to read from the channel, and raises
+   [Failure "input_value: truncated object"] if it reaches the end
+   of file later during the unmarshalling. *)
 
 val from_bytes : bytes -> int -> 'a
 (** [Marshal.from_bytes buff ofs] unmarshals a structured value

diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index e33eb93731379f3229b2129b637309cea83a4a87..9c5ab6905fd8136a3b0be7bfd1e08335894c4ea7 100644 (file)
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -158,6 +158,7 @@ module Set : sig
       val equal : t -> t -> bool
       val subset : t -> t -> bool
       val iter : f:(elt -> unit) -> t -> unit
+      val map : f:(elt -> elt) -> t -> t
       val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a
       val for_all : f:(elt -> bool) -> t -> bool
       val exists : f:(elt -> bool) -> t -> bool

diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index 9990f578cf25c8d009d41ced2fa843f0c0cd3c84..35b3925ae4d9818484764ad39fe2ea4fa1001d6a 100644 (file)
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -20,17 +20,19 @@ type t
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
 external magic : 'a -> 'b = "%identity"
-external is_block : t -> bool = "caml_obj_is_block"
 external is_int : t -> bool = "%obj_is_int"
+let [@inline always] is_block a = not (is_int a)
 external tag : t -> int = "caml_obj_tag"
 external set_tag : t -> int -> unit = "caml_obj_set_tag"
 external size : t -> int = "%obj_size"
+external reachable_words : t -> int = "caml_obj_reachable_words"
 external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
 external array_get: 'a array -> int -> 'a = "%array_safe_get"
 external array_set: 'a array -> int -> 'a -> unit = "%array_safe_set"
-let double_field x i = array_get (obj x : float array) i
-let set_double_field x i v = array_set (obj x : float array) i v
+let [@inline always] double_field x i = array_get (obj x : float array) i
+let [@inline always] set_double_field x i v =
+  array_set (obj x : float array) i v
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"
@@ -77,10 +79,10 @@ let extension_constructor x =
     if (tag name) = string_tag then (obj slot : extension_constructor)
     else invalid_arg "Obj.extension_constructor"
 
-let extension_name (slot : extension_constructor) =
+let [@inline always] extension_name (slot : extension_constructor) =
   (obj (field (repr slot) 0) : string)
 
-let extension_id (slot : extension_constructor) =
+let [@inline always] extension_id (slot : extension_constructor) =
   (obj (field (repr slot) 1) : int)
 
 module Ephemeron = struct

diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index 762abd328d4267f8ad8e389f2325d7ac949b5b03..31c2e45fa36c72b23763c3006b03d62591dddf0f 100644 (file)
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -23,10 +23,19 @@ type t
 external repr : 'a -> t = "%identity"
 external obj : t -> 'a = "%identity"
 external magic : 'a -> 'b = "%identity"
-external is_block : t -> bool = "caml_obj_is_block"
+val [@inline always] is_block : t -> bool
 external is_int : t -> bool = "%obj_is_int"
 external tag : t -> int = "caml_obj_tag"
 external size : t -> int = "%obj_size"
+external reachable_words : t -> int = "caml_obj_reachable_words"
+  (**
+     Computes the total size (in words, including the headers) of all
+     heap blocks accessible from the argument.  Statically
+     allocated blocks are excluded.
+
+     @Since 4.04
+  *)
+
 external field : t -> int -> t = "%obj_field"
 
 (** When using flambda:
@@ -47,8 +56,9 @@ external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
 external set_tag : t -> int -> unit = "caml_obj_set_tag"
 
-val double_field : t -> int -> float  (* @since 3.11.2 *)
-val set_double_field : t -> int -> float -> unit  (* @since 3.11.2 *)
+val [@inline always] double_field : t -> int -> float  (* @since 3.11.2 *)
+val [@inline always] set_double_field : t -> int -> float -> unit
+  (* @since 3.11.2 *)
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"
@@ -77,8 +87,8 @@ val out_of_heap_tag : int
 val unaligned_tag : int   (* should never happen @since 3.11.0 *)
 
 val extension_constructor : 'a -> extension_constructor
-val extension_name : extension_constructor -> string
-val extension_id : extension_constructor -> int
+val [@inline always] extension_name : extension_constructor -> string
+val [@inline always] extension_id : extension_constructor -> int
 
 (** The following two functions are deprecated.  Use module {!Marshal}
     instead. *)

diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 547fade1d7f00dc2d031e65bd5c37e24751f27b0..3b779f5c7fec6880ede3d01b8e2164ec1ace5e79 100644 (file)
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -124,7 +124,7 @@ let clear_parser() =
   Array.fill env.v_stack 0 env.stacksize (Obj.repr ());
   env.lval <- Obj.repr ()
 
-let current_lookahead_fun = ref (fun (x : Obj.t) -> false)
+let current_lookahead_fun = ref (fun (_ : Obj.t) -> false)
 
 let yyparse tables start lexer lexbuf =
   let rec loop cmd arg =
@@ -208,4 +208,4 @@ let rhs_end n = (rhs_end_pos n).pos_cnum
 let is_current_lookahead tok =
   (!current_lookahead_fun)(Obj.repr tok)
 
-let parse_error (msg : string) = ()
+let parse_error (_ : string) = ()

diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index 02c3bbf63880265dde6960e16ae969f43279be10..a8c6310c8cd0181600d29589284cd12b208029b8 100644 (file)
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -186,12 +186,12 @@ external classify_float : (float [@unboxed]) -> fpclass =
 
 external string_length : string -> int = "%string_length"
 external bytes_length : bytes -> int = "%string_length"
-external bytes_create : int -> bytes = "caml_create_string"
+external bytes_create : int -> bytes = "caml_create_bytes"
 external string_blit : string -> int -> bytes -> int -> int -> unit
                      = "caml_blit_string" [@@noalloc]
 external bytes_blit : bytes -> int -> bytes -> int -> int -> unit
-                        = "caml_blit_string" [@@noalloc]
-external bytes_unsafe_to_string : bytes -> string = "%identity"
+                        = "caml_blit_bytes" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
 
 let ( ^ ) s1 s2 =
   let l1 = string_length s1 and l2 = string_length s2 in
@@ -317,7 +317,7 @@ let flush_all () =
   in iter (out_channels_list ())
 
 external unsafe_output : out_channel -> bytes -> int -> int -> unit
-                       = "caml_ml_output"
+                       = "caml_ml_output_bytes"
 external unsafe_output_string : out_channel -> string -> int -> int -> unit
                               = "caml_ml_output"
 
@@ -494,7 +494,7 @@ type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
 
 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
 
-let string_of_format (Format (fmt, str)) = str
+let string_of_format (Format (_fmt, str)) = str
 
 external format_of_string :
  ('a, 'b, 'c, 'd, 'e, 'f) format6 ->

diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index dcc2ba6f32af6c880bcf037b971c62034d956522..1f5e3628e9acc05584e7b1dd8b08f454289b0626 100644 (file)
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -151,7 +151,7 @@ external __LOC__ : string = "%loc_LOC"
     the file currently being parsed by the compiler, with the standard
     error format of OCaml: "File %S, line %d, characters %d-%d".
     @since 4.02.0
- *)
+*)
 
 external __FILE__ : string = "%loc_FILE"
 (** [__FILE__] returns the name of the file currently being
@@ -163,13 +163,13 @@ external __LINE__ : int = "%loc_LINE"
 (** [__LINE__] returns the line number at which this expression
     appears in the file currently being parsed by the compiler.
     @since 4.02.0
- *)
+*)
 
 external __MODULE__ : string = "%loc_MODULE"
 (** [__MODULE__] returns the module name of the file being
     parsed by the compiler.
     @since 4.02.0
- *)
+*)
 
 external __POS__ : string * int * int * int = "%loc_POS"
 (** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding
@@ -186,7 +186,7 @@ external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
     compiler, with the standard error format of OCaml: "File %S, line
     %d, characters %d-%d".
     @since 4.02.0
- *)
+*)
 
 external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
 (** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the

diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 05a3e709da093c5c221175a176410f59f679dabf..1e882f5876279c457d3b731e45517c35cc3aeb5b 100644 (file)
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -39,8 +39,7 @@ let fields x =
   | 0 -> ""
   | 1 -> ""
   | 2 -> sprintf "(%s)" (field x 1)
-  | n -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
-
+  | _ -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
 
 let to_string x =
   let rec conv = function
@@ -85,27 +84,38 @@ let catch fct arg =
     exit 2
 
 type raw_backtrace_slot
-type raw_backtrace = raw_backtrace_slot array
+type raw_backtrace
 
 external get_raw_backtrace:
   unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
 
 type backtrace_slot =
-  | Known_location of bool   (* is_raise *)
-                    * string (* filename *)
-                    * int    (* line number *)
-                    * int    (* start char *)
-                    * int    (* end char *)
-  | Unknown_location of bool (*is_raise*)
+  | Known_location of {
+      is_raise    : bool;
+      filename    : string;
+      line_number : int;
+      start_char  : int;
+      end_char    : int;
+      is_inline   : bool;
+    }
+  | Unknown_location of {
+      is_raise : bool
+    }
 
 (* to avoid warning *)
-let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false]
+let _ = [Known_location { is_raise = false; filename = "";
+                          line_number = 0; start_char = 0; end_char = 0;
+                          is_inline = false };
+         Unknown_location { is_raise = false }]
 
 external convert_raw_backtrace_slot:
   raw_backtrace_slot -> backtrace_slot = "caml_convert_raw_backtrace_slot"
 
-let convert_raw_backtrace rbckt =
-  try Some (Array.map convert_raw_backtrace_slot rbckt)
+external convert_raw_backtrace:
+  raw_backtrace -> backtrace_slot array = "caml_convert_raw_backtrace"
+
+let convert_raw_backtrace bt =
+  try Some (convert_raw_backtrace bt)
   with Failure _ -> None
 
 let format_backtrace_slot pos slot =
@@ -116,12 +126,16 @@ let format_backtrace_slot pos slot =
       if pos = 0 then "Raised by primitive operation at" else "Called from"
   in
   match slot with
-  | Unknown_location true -> (* compiler-inserted re-raise, skipped *) None
-  | Unknown_location false ->
-      Some (sprintf "%s unknown location" (info false))
-  | Known_location(is_raise, filename, lineno, startchar, endchar) ->
-      Some (sprintf "%s file \"%s\", line %d, characters %d-%d"
-              (info is_raise) filename lineno startchar endchar)
+  | Unknown_location l ->
+      if l.is_raise then
+        (* compiler-inserted re-raise, skipped *) None
+      else
+        Some (sprintf "%s unknown location" (info false))
+  | Known_location l ->
+      Some (sprintf "%s file \"%s\"%s, line %d, characters %d-%d"
+              (info l.is_raise) l.filename
+              (if l.is_inline then " (inlined)" else "")
+              l.line_number l.start_char l.end_char)
 
 let print_exception_backtrace outchan backtrace =
   match backtrace with
@@ -159,8 +173,12 @@ let raw_backtrace_to_string raw_backtrace =
   backtrace_to_string (convert_raw_backtrace raw_backtrace)
 
 let backtrace_slot_is_raise = function
-  | Known_location(is_raise, _, _, _, _) -> is_raise
-  | Unknown_location(is_raise) -> is_raise
+  | Known_location l -> l.is_raise
+  | Unknown_location l -> l.is_raise
+
+let backtrace_slot_is_inline = function
+  | Known_location l -> l.is_inline
+  | Unknown_location _ -> false
 
 type location = {
   filename : string;
@@ -171,13 +189,12 @@ type location = {
 
 let backtrace_slot_location = function
   | Unknown_location _ -> None
-  | Known_location(_is_raise, filename, line_number,
-                   start_char, end_char) ->
+  | Known_location l ->
     Some {
-      filename;
-      line_number;
-      start_char;
-      end_char;
+      filename    = l.filename;
+      line_number = l.line_number;
+      start_char  = l.start_char;
+      end_char    = l.end_char;
     }
 
 let backtrace_slots raw_backtrace =
@@ -204,11 +221,19 @@ module Slot = struct
   type t = backtrace_slot
   let format = format_backtrace_slot
   let is_raise = backtrace_slot_is_raise
+  let is_inline = backtrace_slot_is_inline
   let location = backtrace_slot_location
 end
 
-let raw_backtrace_length bckt = Array.length bckt
-let get_raw_backtrace_slot bckt i = Array.get bckt i
+external raw_backtrace_length :
+  raw_backtrace -> int = "caml_raw_backtrace_length" [@@noalloc]
+
+external get_raw_backtrace_slot :
+  raw_backtrace -> int -> raw_backtrace_slot = "caml_raw_backtrace_slot"
+
+external get_raw_backtrace_next_slot :
+  raw_backtrace_slot -> raw_backtrace_slot option
+  = "caml_raw_backtrace_next_slot"
 
 (* confusingly named:
    returns the *string* corresponding to the global current backtrace *)

diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index e6aa68163d1f91047d9b1e75ebdd2137a7a812cf..19bd39c393c0334b335efb9706cf6ddf7a80a975 100644 (file)
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -159,8 +159,8 @@ val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
 
 (** {6 Manipulation of backtrace information}
 
-    Those function allow to traverse the slots of a raw backtrace,
-    extract information from them in a programmer-friendly format.
+    These functions are used to traverse the slots of a raw backtrace
+    and extract information from them in a programmer-friendly format.
 *)
 
 type backtrace_slot
@@ -211,6 +211,14 @@ module Slot : sig
       @since 4.02
   *)
 
+  val is_inline : t -> bool
+  (** [is_inline slot] is [true] when [slot] refers to a call
+      that got inlined by the compiler, and [false] when it comes from
+      any other context.
+
+      @since 4.04.0
+  *)
+
   val location : t -> location option
   (** [location slot] returns the location information of the slot,
       if available, and [None] otherwise.
@@ -277,6 +285,13 @@ val convert_raw_backtrace_slot : raw_backtrace_slot -> backtrace_slot
 *)
 
 
+val get_raw_backtrace_next_slot :
+    raw_backtrace_slot -> raw_backtrace_slot option
+(** [get_raw_backtrace_next_slot slot] returns the next slot inlined, if any.
+
+    @since 4.04.0
+*)
+
 (** {6 Exception slots} *)
 
 val exn_slot_id: exn -> int

diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index fd195b2b5a525df7598571efd030d44429a82650..7be353a1f307e35805da0eaa8caed64601b5797b 100644 (file)
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -1299,9 +1299,9 @@ fun k ign fmt -> match ign with
    take_format_readers, and aggegate scanned values into an
    heterogeneous list. *)
 (* Return the heterogeneous list of scanned values. *)
-let rec make_scanf : type a c d e f .
+let rec make_scanf : type a c d e f.
     Scanning.in_channel -> (a, Scanning.in_channel, c, d, e, f) fmt ->
-      (d, _) heter_list -> (a, f) heter_list =
+      (d, e) heter_list -> (a, f) heter_list =
 fun ib fmt readers -> match fmt with
   | Char rest ->
     let _ = scan_char 0 ib in
@@ -1368,9 +1368,13 @@ fun ib fmt readers -> match fmt with
   | Custom _ ->
     invalid_arg "scanf: bad conversion \"%?\" (custom converter)"
   | Reader fmt_rest ->
-    let Cons (reader, readers_rest) = readers in
-    let x = reader ib in
-    Cons (x, make_scanf ib fmt_rest readers_rest)
+    begin match readers with
+    | Cons (reader, readers_rest) ->
+        let x = reader ib in
+        Cons (x, make_scanf ib fmt_rest readers_rest)
+    | Nil -> 
+        invalid_arg "scanf: missing reader"
+    end
   | Flush rest ->
     if Scanning.end_of_input ib then make_scanf ib rest readers
     else bad_input "end of input not found"
@@ -1460,7 +1464,7 @@ fun ib fmt readers -> match fmt with
 (* Pass padding and precision to the generic scanner `scan'. *)
 and pad_prec_scanf : type a c d e f x y z t .
     Scanning.in_channel -> (a, Scanning.in_channel, c, d, e, f) fmt ->
-      (d, _) heter_list -> (x, y) padding -> (y, z -> a) precision ->
+      (d, e) heter_list -> (x, y) padding -> (y, z -> a) precision ->
       (int -> int -> Scanning.in_channel -> t) ->
       (Scanning.in_channel -> z) ->
       (x, f) heter_list =

diff --git a/stdlib/set.ml b/stdlib/set.ml
index ebbd0a3a609d1f10fffc6131384b8680782b1330..ac10e564cecdc605b819fccd395c1d77764059c9 100644 (file)
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -38,6 +38,7 @@ module type S =
     val equal: t -> t -> bool
     val subset: t -> t -> bool
     val iter: (elt -> unit) -> t -> unit
+    val map: (elt -> elt) -> t -> t
     val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
     val for_all: (elt -> bool) -> t -> bool
     val exists: (elt -> bool) -> t -> bool
@@ -135,12 +136,12 @@ module Make(Ord: OrderedType) =
 
     let rec add_min_element v = function
       | Empty -> singleton v
-      | Node (l, x, r, h) ->
+      | Node (l, x, r, _h) ->
         bal (add_min_element v l) x r
 
     let rec add_max_element v = function
       | Empty -> singleton v
-      | Node (l, x, r, h) ->
+      | Node (l, x, r, _h) ->
         bal l x (add_max_element v r)
 
     (* Same as create and bal, but no assumptions are made on the
@@ -159,19 +160,19 @@ module Make(Ord: OrderedType) =
 
     let rec min_elt = function
         Empty -> raise Not_found
-      | Node(Empty, v, r, _) -> v
-      | Node(l, v, r, _) -> min_elt l
+      | Node(Empty, v, _, _) -> v
+      | Node(l, _, _, _) -> min_elt l
 
     let rec max_elt = function
         Empty -> raise Not_found
-      | Node(l, v, Empty, _) -> v
-      | Node(l, v, r, _) -> max_elt r
+      | Node(_, v, Empty, _) -> v
+      | Node(_, _, r, _) -> max_elt r
 
     (* Remove the smallest element of the given set *)
 
     let rec remove_min_elt = function
         Empty -> invalid_arg "Set.remove_min_elt"
-      | Node(Empty, v, r, _) -> r
+      | Node(Empty, _, r, _) -> r
       | Node(l, v, r, _) -> bal (remove_min_elt l) v r
 
     (* Merge two trees l and r into one.
@@ -256,8 +257,8 @@ module Make(Ord: OrderedType) =
 
     let rec inter s1 s2 =
       match (s1, s2) with
-        (Empty, t2) -> Empty
-      | (t1, Empty) -> Empty
+        (Empty, _) -> Empty
+      | (_, Empty) -> Empty
       | (Node(l1, v1, r1, _), t2) ->
           match split v1 t2 with
             (l2, false, r2) ->
@@ -267,7 +268,7 @@ module Make(Ord: OrderedType) =
 
     let rec diff s1 s2 =
       match (s1, s2) with
-        (Empty, t2) -> Empty
+        (Empty, _) -> Empty
       | (t1, Empty) -> t1
       | (Node(l1, v1, r1, _), t2) ->
           match split v1 t2 with
@@ -356,7 +357,7 @@ module Make(Ord: OrderedType) =
 
     let rec cardinal = function
         Empty -> 0
-      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+      | Node(l, _, r, _) -> cardinal l + 1 + cardinal r
 
     let rec elements_aux accu = function
         Empty -> accu
@@ -374,6 +375,21 @@ module Make(Ord: OrderedType) =
           if c = 0 then v
           else find x (if c < 0 then l else r)
 
+    let rec map f = function
+      | Empty -> Empty
+      | Node (l, v, r, _) as t ->
+         (* enforce left-to-right evaluation order *)
+         let l' = map f l in
+         let v' = f v in
+         let r' = map f r in
+         if l == l' && v == v' && r == r' then t
+         else begin
+             if (l' = Empty || Ord.compare (max_elt l') v < 0)
+                && (r' = Empty || Ord.compare v (min_elt r') < 0)
+             then join l' v' r'
+             else union l' (add v' r')
+         end
+
     let of_sorted_list l =
       let rec sub n l =
         match n, l with

diff --git a/stdlib/set.mli b/stdlib/set.mli
index 5d968e0cfb8cda26aaaeb3812a94ce6b22de8fd6..f57999eb1f89df971e1c7b16d2ac8a81a5452293 100644 (file)
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -118,6 +118,17 @@ module type S =
        The elements of [s] are presented to [f] in increasing order
        with respect to the ordering over the type of the elements. *)
 
+    val map: (elt -> elt) -> t -> t
+    (** [map f s] is the set whose elements are [f a0],[f a1]... [f
+        aN], where [a0],[a1]...[aN] are the elements of [s].
+
+       The elements are passed to [f] in increasing order
+       with respect to the ordering over the type of the elements.
+
+       If no element of [s] is changed by [f], [s] is returned
+       unchanged. (If each output of [f] is physically equal to its
+       input, the returned set is physically equal to [s].) *)
+
     val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
     (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
        where [x1 ... xN] are the elements of [s], in increasing order. *)

diff --git a/stdlib/sharpbang b/stdlib/sharpbang
deleted file mode 100644 (file)
index 04c9334..0000000
--- a/stdlib/sharpbang
+++ /dev/null
@@ -1 +0,0 @@
-#! 
\ No newline at end of file

diff --git a/stdlib/spacetime.ml b/stdlib/spacetime.ml
new file mode 100644 (file)
index 0000000..56dde7c
--- /dev/null
+++ b/stdlib/spacetime.ml
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+external spacetime_enabled : unit -> bool
+  = "caml_spacetime_enabled" [@@noalloc]
+
+let if_spacetime_enabled f =
+  if spacetime_enabled () then f () else ()
+
+module Series = struct
+  type t = {
+    channel : out_channel;
+    mutable closed : bool;
+  }
+
+  external write_magic_number : out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_write_magic_number"
+
+  external register_channel_for_spacetime : out_channel -> unit
+    = "caml_register_channel_for_spacetime"
+
+  let create ~path =
+    if spacetime_enabled () then begin
+      let channel = open_out path in
+      register_channel_for_spacetime channel;
+      let t =
+        { channel = channel;
+          closed = false;
+        }
+      in
+      write_magic_number t.channel;
+      t
+    end else begin
+      { channel = stdout;  (* arbitrary value *)
+        closed = true;
+      }
+    end
+
+  external save_event : ?time:float -> out_channel -> event_name:string -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_save_event"
+
+  let save_event ?time t ~event_name =
+    if_spacetime_enabled (fun () ->
+      save_event ?time t.channel ~event_name)
+
+  external save_trie : ?time:float -> out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_save_trie"
+
+  let save_and_close ?time t =
+    if_spacetime_enabled (fun () ->
+      if t.closed then failwith "Series is closed";
+      save_trie ?time t.channel;
+      close_out t.channel;
+      t.closed <- true)
+end
+
+module Snapshot = struct
+  external take : ?time:float -> out_channel -> unit
+    = "caml_spacetime_only_works_for_native_code"
+      "caml_spacetime_take_snapshot"
+
+  let take ?time { Series.closed; channel } =
+    if_spacetime_enabled (fun () ->
+      if closed then failwith "Series is closed";
+      Gc.minor ();
+      take ?time channel)
+end
+
+external save_event_for_automatic_snapshots : event_name:string -> unit
+  = "caml_spacetime_only_works_for_native_code"
+    "caml_spacetime_save_event_for_automatic_snapshots"
+
+let save_event_for_automatic_snapshots ~event_name =
+  if_spacetime_enabled (fun () ->
+    save_event_for_automatic_snapshots ~event_name)

diff --git a/stdlib/spacetime.mli b/stdlib/spacetime.mli
new file mode 100644 (file)
index 0000000..5f3b51e
--- /dev/null
+++ b/stdlib/spacetime.mli
@@ -0,0 +1,95 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Profiling of a program's space behaviour over time.
+    Currently only supported on x86-64 platforms running 64-bit code.
+
+    To use the functions in this module you must:
+    - configure the compiler with "-spacetime";
+    - compile to native code.
+    Without these conditions being satisfied the functions in this module
+    will have no effect.
+
+    Instead of manually taking profiling heap snapshots with this module it is
+    possible to use an automatic snapshot facility that writes profiling
+    information at fixed intervals to a file. To enable this, all that needs to
+    be done is to build the relevant program using a compiler configured with
+    -spacetime; and set the environment variable OCAML_SPACETIME_INTERVAL to an
+    integer number of milliseconds giving the interval between profiling heap
+    snapshots. This interval should not be made excessively small relative to
+    the running time of the program. A typical interval to start with might be
+    1/100 of the running time of the program.  The program must exit "normally"
+    (i.e. by calling [exit], with whatever exit code, rather than being
+    abnormally terminated by a signal) so that the snapshot file is
+    correctly completed.
+
+    When using the automatic snapshot mode the profiling output is written
+    to a file called "spacetime-<pid>" where <pid> is the process ID of the
+    program.  (If the program forks and continues executing then multiple
+    files may be produced with different pid numbers.)  The profiling output
+    is by default written to the current working directory when the program
+    starts.  This may be customised by setting the OCAML_SPACETIME_SNAPSHOT_DIR
+    environment variable to the name of the desired directory.
+
+    If using automatic snapshots the presence of the
+    [save_event_for_automatic_snapshots] function, below, should be noted.
+
+    The functions in this module are thread safe.
+
+    For functions to decode the information recorded by the profiler,
+    see the Spacetime offline library in otherlibs/. *)
+
+module Series : sig
+  (** Type representing a file that will hold a series of heap snapshots
+      together with additional information required to interpret those
+      snapshots. *)
+  type t
+
+  (** [create ~path] creates a series file at [path]. *)
+  val create : path:string -> t
+
+  (** [save_event] writes an event, which is an arbitrary string, into the
+      given series file.  This may be used for identifying particular points
+      during program execution when analysing the profile.
+      The optional [time] parameter is as for [Snapshot.take].
+  *)
+  val save_event : ?time:float -> t -> event_name:string -> unit
+
+  (** [save_and_close series] writes information into [series] required for
+      interpeting the snapshots that [series] contains and then closes the
+      [series] file. This function must be called to produce a valid series
+      file.
+      The optional [time] parameter is as for [Snapshot.take].
+  *)
+  val save_and_close : ?time:float -> t -> unit
+end
+
+module Snapshot : sig
+  (** [take series] takes a snapshot of the profiling annotations on the values
+      in the minor and major heaps, together with GC stats, and write the
+      result to the [series] file.  This function triggers a minor GC but does
+      not allocate any memory itself.
+      If the optional [time] is specified, it will be used instead of the
+      result of [Sys.time] as the timestamp of the snapshot.  Such [time]s
+      should start from zero and be monotonically increasing.  This parameter
+      is intended to be used so that snapshots can be correlated against wall
+      clock time (which is not supported in the standard library) rather than
+      elapsed CPU time.
+  *)
+  val take : ?time:float -> Series.t -> unit
+end
+
+(** Like [Series.save_event], but writes to the automatic snapshot file.
+    This function is a no-op if OCAML_SPACETIME_INTERVAL was not set. *)
+val save_event_for_automatic_snapshots : event_name:string -> unit

diff --git a/stdlib/stream.ml b/stdlib/stream.ml
index 73c8dfb2260b61f73daf8d18b179a496cac00a7d..e9b5e6113c44c2a5fb89c144dd781e7e401764f8 100644 (file)
--- a/stdlib/stream.ml
+++ b/stdlib/stream.ml
@@ -52,8 +52,8 @@ let rec get_data : type v. int -> v data -> v data = fun count d -> match d with
      | Sempty -> get_data count d2
      | _ -> assert false
      end
- | Sgen {curr = Some None; func = _ } -> Sempty
- | Sgen ({curr = Some(Some a); func = f} as g) ->
+ | Sgen {curr = Some None} -> Sempty
+ | Sgen ({curr = Some(Some a)} as g) ->
      g.curr <- None; Scons(a, d)
  | Sgen g ->
      begin match g.func count with
@@ -230,4 +230,4 @@ and dump_data : type v. (v -> unit) -> v data -> unit = fun f ->
       print_string ")"
   | Slazy _ -> print_string "Slazy"
   | Sgen _ -> print_string "Sgen"
-  | Sbuffio b -> print_string "Sbuffio"
+  | Sbuffio _ -> print_string "Sbuffio"

diff --git a/stdlib/string.ml b/stdlib/string.ml
index 7189ce99f3414c5e0c3f5fe2f049209c176c911c..9c4a97f2c1a8e029ff3b89d0180a8645b943644a 100644 (file)
--- a/stdlib/string.ml
+++ b/stdlib/string.ml
@@ -15,6 +15,12 @@
 
 (* String operations, based on byte sequence operations *)
 
+(* WARNING: Some functions in this file are duplicated in bytes.ml for
+   efficiency reasons. When you modify the one in this file you need to
+   modify its duplicate in bytes.ml.
+   These functions have a "duplicated" comment above their definition.
+*)
+
 external length : string -> int = "%string_length"
 external get : string -> int -> char = "%string_safe_get"
 external set : bytes -> int -> char -> unit = "%string_safe_set"
@@ -44,28 +50,37 @@ let fill =
 let blit =
   B.blit_string
 
-let concat sep l =
-  match l with
-  | [] -> ""
-  | hd :: tl ->
-      let num = ref 0 and len = ref 0 in
-      List.iter (fun s -> incr num; len := !len + length s) l;
-      let r = B.create (!len + length sep * (!num - 1)) in
-      unsafe_blit hd 0 r 0 (length hd);
-      let pos = ref(length hd) in
-      List.iter
-        (fun s ->
-          unsafe_blit sep 0 r !pos (length sep);
-          pos := !pos + length sep;
-          unsafe_blit s 0 r !pos (length s);
-          pos := !pos + length s)
-        tl;
-      Bytes.unsafe_to_string r
+let ensure_ge x y = if x >= y then x else invalid_arg "String.concat"
+
+let rec sum_lengths acc seplen = function
+  | [] -> acc
+  | hd :: [] -> length hd + acc
+  | hd :: tl -> sum_lengths (ensure_ge (length hd + seplen + acc) acc) seplen tl
 
+let rec unsafe_blits dst pos sep seplen = function
+    [] -> dst
+  | hd :: [] ->
+    unsafe_blit hd 0 dst pos (length hd); dst
+  | hd :: tl ->
+    unsafe_blit hd 0 dst pos (length hd);
+    unsafe_blit sep 0 dst (pos + length hd) seplen;
+    unsafe_blits dst (pos + length hd + seplen) sep seplen tl
+
+let concat sep = function
+    [] -> ""
+  | l -> let seplen = length sep in bts @@
+          unsafe_blits 
+            (B.create (sum_lengths 0 seplen l))
+            0 sep seplen l
+
+(* duplicated in bytes.ml *)
 let iter f s =
-  B.iter f (bos s)
+  for i = 0 to length s - 1 do f (unsafe_get s i) done
+
+(* duplicated in bytes.ml *)
 let iteri f s =
-  B.iteri f (bos s)
+  for i = 0 to length s - 1 do f i (unsafe_get s i) done
+
 let map f s =
   B.map f (bos s) |> bts
 let mapi f s =
@@ -98,20 +113,52 @@ let escaped s =
   else
     s
 
-let index s c =
-  B.index (bos s) c
-let rindex s c =
-  B.rindex (bos s) c
-let index_from s i c=
-  B.index_from (bos s) i c
+(* duplicated in bytes.ml *)
+let rec index_rec s lim i c =
+  if i >= lim then raise Not_found else
+  if unsafe_get s i = c then i else index_rec s lim (i + 1) c
+
+(* duplicated in bytes.ml *)
+let index s c = index_rec s (length s) 0 c
+
+(* duplicated in bytes.ml *)
+let index_from s i c =
+  let l = length s in
+  if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
+    index_rec s l i c
+
+(* duplicated in bytes.ml *)
+let rec rindex_rec s i c =
+  if i < 0 then raise Not_found else
+  if unsafe_get s i = c then i else rindex_rec s (i - 1) c
+
+(* duplicated in bytes.ml *)
+let rindex s c = rindex_rec s (length s - 1) c
+
+(* duplicated in bytes.ml *)
 let rindex_from s i c =
-  B.rindex_from (bos s) i c
-let contains s c =
-  B.contains (bos s) c
+  if i < -1 || i >= length s then
+    invalid_arg "String.rindex_from / Bytes.rindex_from"
+  else
+    rindex_rec s i c
+
+(* duplicated in bytes.ml *)
 let contains_from s i c =
-  B.contains_from (bos s) i c
+  let l = length s in
+  if i < 0 || i > l then
+    invalid_arg "String.contains_from / Bytes.contains_from"
+  else
+    try ignore (index_rec s l i c); true with Not_found -> false
+
+(* duplicated in bytes.ml *)
+let contains s c = contains_from s 0 c
+
+(* duplicated in bytes.ml *)
 let rcontains_from s i c =
-  B.rcontains_from (bos s) i c
+  if i < 0 || i >= length s then
+    invalid_arg "String.rcontains_from / Bytes.rcontains_from"
+  else
+    try ignore (rindex_rec s i c); true with Not_found -> false
 
 let uppercase_ascii s =
   B.uppercase_ascii (bos s) |> bts
@@ -127,6 +174,17 @@ type t = string
 let compare (x: t) (y: t) = Pervasives.compare x y
 external equal : string -> string -> bool = "caml_string_equal"
 
+let split_on_char sep s =
+  let r = ref [] in
+  let j = ref (length s) in
+  for i = length s - 1 downto 0 do
+    if unsafe_get s i = sep then begin
+      r := sub s (i + 1) (!j - i - 1) :: !r;
+      j := i
+    end
+  done;
+  sub s 0 !j :: !r
+
 (* Deprecated functions implemented via other deprecated functions *)
 [@@@ocaml.warning "-3"]
 let uppercase s =

diff --git a/stdlib/string.mli b/stdlib/string.mli
index b7d895658fe498b44895d59a9d7f565864719f64..5c66cd00532d3b01fcc4a0532f1e28dfc0f0492d 100644 (file)
--- a/stdlib/string.mli
+++ b/stdlib/string.mli
@@ -282,6 +282,21 @@ val equal: t -> t -> bool
 (** The equal function for strings.
     @since 4.03.0 *)
 
+val split_on_char: char -> string -> string list
+(** [String.split_on_char sep s] returns the list of all (possibly empty)
+    substrings of [s] that are delimited by the [sep] character.
+
+    The function's output is specified by the following invariants:
+
+    - The list is not empty.
+    - Concatenating its elements using [sep] as a separator returns a
+      string equal to the input ([String.concat (String.make 1 sep)
+      (String.split_on_char sep s) = s]).
+    - No string in the result contains the [sep] character.
+
+    @since 4.04.0
+*)
+
 (**/**)
 
 (* The following is for system use only. Do not call directly. *)

diff --git a/stdlib/sys.mli b/stdlib/sys.mli
index e5c69e5e775ab8a56f26dc4cd3271075a6c7c3b1..d20613417fa66392d509bed0c1ede7c87e2a7e05 100644 (file)
--- a/stdlib/sys.mli
+++ b/stdlib/sys.mli
@@ -86,6 +86,22 @@ val os_type : string
 -  ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw),
 -  ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *)
 
+type backend_type =
+  | Native
+  | Bytecode
+  | Other of string (**)
+(** Currently, the official distribution only supports [Native] and
+    [Bytecode], but it can be other backends with alternative
+    compilers, for example, javascript.
+
+    @since 4.04.0
+*)
+
+val backend_type : backend_type
+(** Backend type  currently executing the OCaml program.
+    @ since 4.04.0
+ *)
+
 val unix : bool
 (** True if [Sys.os_type = "Unix"].
     @since 4.01.0 *)
@@ -278,10 +294,14 @@ val enable_runtime_warnings: bool -> unit
 (** Control whether the OCaml runtime system can emit warnings
     on stderr.  Currently, the only supported warning is triggered
     when a channel created by [open_*] functions is finalized without
-    being closed.  Runtime warnings are enabled by default. *)
+    being closed.  Runtime warnings are enabled by default.
+
+    @since 4.03.0 *)
 
 val runtime_warnings_enabled: unit -> bool
-(** Return whether runtime warnings are currently enabled. *)
+(** Return whether runtime warnings are currently enabled.
+
+    @since 4.03.0 *)
 
 (** {6 Optimization} *)
 
@@ -298,4 +318,6 @@ external opaque_identity : 'a -> 'a = "%opaque"
         ignore (Sys.opaque_identity (my_pure_computation ()))
       done
     ]}
+
+    @since 4.03.0
 *)

diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp
index d9fec96a7bdb4ce7a5ea5525de9e3c9f92f29a07..7e79cbd9810fe41ae974f25807e4bdff27d6a644 100644 (file)
--- a/stdlib/sys.mlp
+++ b/stdlib/sys.mlp
@@ -1,3 +1,4 @@
+#2 "stdlib/sys.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -17,6 +18,10 @@
    your changes will be lost.
 *)
 
+type backend_type =
+  | Native
+  | Bytecode
+  | Other of string
 (* System interface *)
 
 external get_config: unit -> string * int * bool = "caml_sys_get_config"
@@ -28,9 +33,11 @@ external max_wosize : unit -> int = "%max_wosize"
 external unix : unit -> bool = "%ostype_unix"
 external win32 : unit -> bool = "%ostype_win32"
 external cygwin : unit -> bool = "%ostype_cygwin"
+external get_backend_type : unit -> backend_type = "%backend_type"
 
 let (executable_name, argv) = get_argv()
 let (os_type, _, _) = get_config()
+let backend_type = get_backend_type ()
 let big_endian = big_endian ()
 let word_size = word_size ()
 let int_size = int_size ()

diff --git a/stdlib/weak.ml b/stdlib/weak.ml
index d2d71576f09dc1dac0dfac657e071132b1f4a25b..631c73e0faf1c5428dadc38d0b1a768d6f452aa5 100644 (file)
--- a/stdlib/weak.ml
+++ b/stdlib/weak.ml
@@ -200,7 +200,9 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
     let sz = length bucket in
     let rec loop i =
       if i >= sz then begin
-        let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in
+        let newsz =
+          min (3 * sz / 2 + 3) (Sys.max_array_length - additional_values)
+        in
         if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
         let newbucket = weak_create newsz in
         let newhashes = Array.make newsz 0 in
@@ -255,7 +257,8 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
     find_or t d (fun h index -> add_aux t set (Some d) h index; d)
 
 
-  let find t d = find_or t d (fun h index -> raise Not_found)
+  let find t d = find_or t d (fun _h _index -> raise Not_found)
+
 
   let find_shadow t d iffound ifnotfound =
     let h = H.hash d in
@@ -276,7 +279,9 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
 
   let remove t d = find_shadow t d (fun w i -> set w i None) ()
 
-  let mem t d = find_shadow t d (fun w i -> true) false
+
+  let mem t d = find_shadow t d (fun _w _i -> true) false
+
 
   let find_all t d =
     let h = H.hash d in

diff --git a/stdlib/weak.mli b/stdlib/weak.mli
index 64b58c52a0a62fecb2562ae59096ece4982acd8b..952494449f696b1a714939ff6649f459886ad253 100644 (file)
--- a/stdlib/weak.mli
+++ b/stdlib/weak.mli
@@ -105,7 +105,7 @@ val blit : 'a t -> int -> 'a t -> int -> int -> unit
 
 module type S = sig
   type data
-    (** The type of the elements stored in the table. *)
+  (** The type of the elements stored in the table. *)
 
   type t
     (** The type of tables that contain elements of type [data].
@@ -118,7 +118,7 @@ module type S = sig
         size [n].  The table will grow as needed. *)
 
   val clear : t -> unit
-    (** Remove all elements from the table. *)
+  (** Remove all elements from the table. *)
 
   val merge : t -> data -> data
     (** [merge t x] returns an instance of [x] found in [t] if any,

diff --git a/testsuite/Makefile b/testsuite/Makefile
index 48007f34a608bf681125ba0a23fea5f226d664f4..828272b2a44005321b04db4a8d1f5229e718dd69 100644 (file)
--- a/testsuite/Makefile
+++ b/testsuite/Makefile
@@ -32,6 +32,7 @@ default:
        @echo "  one DIR=p       launch the tests located in path p"
        @echo "  promote DIR=p   promote the reference files for the tests in p"
        @echo "  lib             build library modules"
+       @echo "  tools           build test tools"
        @echo "  clean           delete generated files"
        @echo "  report          print the report for the last execution"
        @echo
@@ -40,7 +41,7 @@ default:
        @echo "(default value = $(MAX_TESTSUITE_DIR_RETRIES))"
 
 .PHONY: all
-all: lib
+all: lib tools
        @for dir in tests/*; do \
          $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
        done 2>&1 | tee _log
@@ -48,7 +49,7 @@ all: lib
        @$(MAKE) report
 
 .PHONY: all-%
-all-%: lib
+all-%: lib tools
        @for dir in tests/$**; do \
          $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
        done 2>&1 | tee _log
@@ -80,7 +81,7 @@ all-%: lib
 # but the demangling separation is arguably nicer behavior that we might
 # want to implement at the exec-one level to also have it in the 'all' target.
 .PHONY: parallel-%
-parallel-%: lib
+parallel-%: lib tools
        @echo | parallel >/dev/null 2>/dev/null \
         || (echo "Unable to run the GNU parallel tool;";\
             echo "You should install it before using the parallel* targets.";\
@@ -100,7 +101,7 @@ parallel-%: lib
 parallel: parallel-*
 
 .PHONY: list
-list: lib
+list: lib tools
        @if [ -z "$(FILE)" ]; \
          then echo "No value set for variable 'FILE'."; \
          exit 1; \
@@ -112,7 +113,7 @@ list: lib
        @$(MAKE) report
 
 .PHONY: one
-one: lib
+one: lib tools
        @if [ -z "$(DIR)" ]; then \
          echo "No value set for variable 'DIR'."; \
          exit 1; \
@@ -165,9 +166,14 @@ promote:
 lib:
        @cd lib && $(MAKE) -s BASEDIR=$(BASEDIR)
 
+.PHONY: tools
+tools:
+       @cd tools && $(MAKE) -s BASEDIR=$(BASEDIR)
+
 .PHONY: clean
 clean:
        @cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean
+       @cd tools && $(MAKE) BASEDIR=$(BASEDIR) clean
        @for file in `$(FIND) interactive tests -name Makefile`; do \
          (cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \
        done

diff --git a/testsuite/lib/empty b/testsuite/lib/empty
deleted file mode 100644 (file)
index e69de29..0000000

diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common
index 8b3a075d3afae5924b30089f90350ea0def8302c..91ab0146692e9d31834e389722eacb83c8998112 100644 (file)
--- a/testsuite/makefiles/Makefile.common
+++ b/testsuite/makefiles/Makefile.common
@@ -14,92 +14,7 @@
 #**************************************************************************
 
 TOPDIR=$(BASEDIR)/..
-WINTOPDIR=`cygpath -m "$(TOPDIR)"`
-
-# TOPDIR is the root directory of the OCaml sources, in Unix syntax.
-# WINTOPDIR is the same directory, in Windows syntax.
-
-OTOPDIR=$(TOPDIR)
-CTOPDIR=$(TOPDIR)
-CYGPATH=echo
-DIFF=diff -q
-SORT=sort
-SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)"
-
-# The variables above may be overridden by .../config/Makefile
-# OTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
-#   arguments given to the OCaml compiler.
-# CTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for
-#   arguments given to the C and Fortran compilers.
-# CYGPATH is the command that translates unix-style file names into
-#   whichever syntax is appropriate for arguments of OCaml programs.
-# DIFF is a "diff -q" command that ignores trailing CRs under Windows.
-# SORT is the Unix "sort" command. Usually a simple command, but may be an
-#   absolute name if the Windows "sort" command is in the PATH.
-# SET_LD_PATH is a command prefix that sets the path for dynamic libraries
-#   (CAML_LD_LIBRARY_PATH for Unix, PATH for Windows) using the LD_PATH shell
-#   variable. Note that for Windows we add Unix-syntax directory names in
-#   PATH, and Cygwin will translate it to Windows syntax.
-
-include $(TOPDIR)/config/Makefile
-
-ifneq ($(USE_RUNTIME),)
-#Check USE_RUNTIME value
-ifeq ($(findstring $(USE_RUNTIME),d i),)
-$(error If set, USE_RUNTIME must be equal to "d" (debug runtime) \
-        or "i" (instrumented runtime))
-endif
-
-RUNTIME_VARIANT=-I $(OTOPDIR)/asmrun -I $(OTOPDIR)/byterun \
-                -runtime-variant $(USE_RUNTIME)
-export OCAMLRUNPARAM?=v=0
-endif
-
-OCAMLRUN=$(TOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE)
-
-OCFLAGS=-nostdlib -I $(OTOPDIR)/stdlib $(COMPFLAGS)
-OCOPTFLAGS=
-
-ifeq ($(SUPPORTS_SHARED_LIBRARIES),false)
-  CUSTOM = -custom
-else
-  CUSTOM =
-endif
-
-OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) \
-      -init $(OTOPDIR)/testsuite/lib/empty
-ifeq "$(FLEXLINK)" ""
-  FLEXLINK_PREFIX=
-else
-  ifeq "$(wildcard $(TOPDIR)/flexdll/Makefile)" ""
-    FLEXLINK_PREFIX=
-  else
-    EMPTY=
-    FLEXLINK_PREFIX=OCAML_FLEXLINK="$(WINTOPDIR)/boot/ocamlrun \
-                                   $(WINTOPDIR)/flexdll/flexlink.exe" $(EMPTY)
-  endif
-endif
-OCAMLC=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/ocamlc $(CUSTOM) $(OCFLAGS) \
-       $(RUNTIME_VARIANT)
-OCAMLOPT=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/ocamlopt $(OCFLAGS) \
-         $(RUNTIME_VARIANT)
-OCAMLDOC=$(OCAMLRUN) $(OTOPDIR)/ocamldoc/ocamldoc
-OCAMLLEX=$(OCAMLRUN) $(OTOPDIR)/lex/ocamllex
-OCAMLMKLIB=$(FLEXLINK_PREFIX)$(OCAMLRUN) $(OTOPDIR)/tools/ocamlmklib \
-           -ocamlc "$(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) \
-                    $(OTOPDIR)/ocamlc $(OCFLAGS) $(RUNTIME_VARIANT)" \
-           -ocamlopt "$(OTOPDIR)/byterun/ocamlrun$(USE_RUNTIME)$(EXE) \
-                      $(OTOPDIR)/ocamlopt $(OCFLAGS) $(RUNTIME_VARIANT)"
-OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE)
-DUMPOBJ=$(OCAMLRUN) $(OTOPDIR)/tools/dumpobj
-OBJINFO=$(OCAMLRUN) $(OTOPDIR)/tools/objinfo
-BYTECODE_ONLY=[ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]
-NATIVECODE_ONLY=false
-
-#FORTRAN_COMPILER=
-#FORTRAN_LIBRARY=
-
-UNIXLIBVAR=`case "$(OTHERLIBRARIES)" in *win32unix*) echo win32;; esac`
+include $(TOPDIR)/Makefile.tools
 
 defaultpromote:
        @for file in *.reference; do \
@@ -108,6 +23,7 @@ defaultpromote:
 
 defaultclean:
        @rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A) *.exe
+       @rm -f *.exe.manifest
        @for dsym in *.dSYM; do \
          if [ -d $$dsym ]; then \
            rm -fr $$dsym; \

diff --git a/testsuite/makefiles/Makefile.expect b/testsuite/makefiles/Makefile.expect
new file mode 100644 (file)
index 0000000..0b219ee
--- /dev/null
+++ b/testsuite/makefiles/Makefile.expect
@@ -0,0 +1,32 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group LLC                                 *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+default:
+       @for file in *.ml; do \
+         printf " ... testing '$$file':"; \
+         TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) $$file && \
+         TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) -principal \
+           $$file.corrected && \
+         mv $$file.corrected.corrected $$file.corrected && \
+         $(DIFF) $$file $$file.corrected && \
+         echo " => passed" || echo " => failed"; \
+       done
+
+promote:
+       @for file in *.corrected; do \
+         cp $$file `basename $$file .corrected`; \
+       done
+
+clean: defaultclean
+       @rm -f *.corrected

diff --git a/testsuite/makefiles/Makefile.okbad b/testsuite/makefiles/Makefile.okbad
index e3928dd96628c801462717182dc94a96aee71c33..d463181ebaa666e54d6bf9733dc0c1c02d1a7fa1 100644 (file)
--- a/testsuite/makefiles/Makefile.okbad
+++ b/testsuite/makefiles/Makefile.okbad
@@ -16,21 +16,30 @@
 .PHONY: default
 default: compile
 
+# See run-file in Makefile.several for the use of mktemp
 .PHONY: compile
 compile:
        @for file in *.ml; do \
          printf " ... testing '$$file'"; \
+         if [ `echo $$file | grep principal` ]; \
+         then PRIN="-principal -w +18+19 -warn-error A"; \
+         else PRIN=""; fi; \
          if [ `echo $$file | grep bad` ]; then \
-           $(OCAMLC) -c -w a $$file 2>/dev/null \
+           $(OCAMLC) -c -w a $$PRIN $$file 2>/dev/null \
             && echo " => failed" || echo " => passed"; \
          else \
            F="`basename $$file .ml`"; \
-           test -f $$F.mli && $(OCAMLC) -c -w a $$F.mli; \
-           $(OCAMLC) -c -w a $$file 2>/dev/null \
+           test -f $$F.mli && $(OCAMLC) -c -w a $$PRIN $$F.mli; \
+           $(OCAMLC) -c -w a $$PRIN $$file 2>/dev/null \
            && if [ -f $$F.reference ]; then \
-                rm -f program.byte; \
-                $(OCAMLC) $$F.cmo -o program.byte \
-                && $(OCAMLRUN) program.byte >$$F.result \
+                test -e program.byte.exe && { \
+                  T="`mktemp -p .`"; \
+                  mv -f program.byte.exe "$$T"; \
+                  rm -f "$$T"; \
+                } ; \
+                rm -f program.byte program.byte.exe; \
+                $(OCAMLC) $$F.cmo -o program.byte$(EXE) \
+                && $(OCAMLRUN) program.byte$(EXE) >$$F.result \
                 && $(DIFF) $$F.reference $$F.result >/dev/null; \
               fi \
            && echo " => passed" || echo " => failed"; \
@@ -42,4 +51,4 @@ promote: defaultpromote
 
 .PHONY: clean
 clean: defaultclean
-       @rm -f program.byte *.cm* *.result
+       @rm -f program.byte program.byte.exe *.cm* *.result

diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one
index 7488e3c357627446d7a5ec3fb25c76677ccfdde3..c98fbb59a7911d60678245964f5f31cea443aefc 100644 (file)
--- a/testsuite/makefiles/Makefile.one
+++ b/testsuite/makefiles/Makefile.one
@@ -41,12 +41,19 @@ default:
         && echo " ... testing => skipped" \
         || $(SET_LD_PATH) $(MAKE) run
 
+# See run-file in Makefile.several for the use of mktemp (included for
+# completeness; should be unnecessary)
 .PHONY: compile
 compile: $(ML_FILES)
        @for file in $(C_FILES); do \
          $(OCAMLC) -c $(C_INCLUDES) $$file.c; \
        done
        @if $(NATIVECODE_ONLY); then : ; else \
+         test -e program.byte.exe && { \
+           T="`mktemp -p .`"; \
+           mv -f program.byte.exe "$$T"; \
+           rm -f "$$T"; \
+         } ; \
          rm -f program.byte program.byte.exe; \
          $(MAKE) $(CMO_FILES) $(MAIN_MODULE).cmo; \
          $(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \
@@ -54,6 +61,11 @@ compile: $(ML_FILES)
                    $(MAIN_MODULE).cmo; \
        fi
        @if $(BYTECODE_ONLY); then : ; else \
+         test -e program.native.exe && { \
+           T="`mktemp -p .`"; \
+           mv -f program.native.exe "$$T"; \
+           rm -f "$$T"; \
+         } ; \
          rm -f program.native program.native.exe; \
          $(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \
          $(OCAMLOPT) $(ADD_COMPFLAGS) $(ADD_OPTCOMPFLAGS) \
@@ -67,14 +79,15 @@ run:
        @printf " ... testing with"
        @if $(NATIVECODE_ONLY); then : ; else \
           printf " ocamlc"; \
-          $(MYRUNTIME) ./program.byte$(EXE) $(EXEC_ARGS) \
+          FLAMBDA=$(FLAMBDA) $(MYRUNTIME) ./program.byte$(EXE) $(EXEC_ARGS) \
                        >$(MAIN_MODULE).result \
           && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
              >/dev/null; \
         fi \
        && if $(BYTECODE_ONLY); then : ; else \
             printf " ocamlopt"; \
-            ./program.native$(EXE) $(EXEC_ARGS) > $(MAIN_MODULE).result \
+            FLAMBDA=$(FLAMBDA) ./program.native$(EXE) $(EXEC_ARGS) \
+                                    > $(MAIN_MODULE).result \
             && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
                        >/dev/null; \
           fi \

diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several
index d5299d74fee2e777964a729fba0b3dc5257012ef..f24aff9112237217aca803bed469f313c34cf693 100644 (file)
--- a/testsuite/makefiles/Makefile.several
+++ b/testsuite/makefiles/Makefile.several
@@ -30,6 +30,8 @@ ADD_OPTFLAGS+=$(FORTRAN_LIB)
 
 C_INCLUDES+=-I $(CTOPDIR)/byterun -I$(CTOPDIR)/otherlibs/bigarray
 
+GENERATED_SOURCES=
+
 SKIP=false
 
 .PHONY: check
@@ -95,10 +97,23 @@ run-all:
          && echo " => passed" || echo " => failed"; \
        done
 
+# On Windows, nefarious software (specifically Windows Defender) can prevent
+# executable files being deleted while it scans them. Unfortunately, it does
+# this by allowing the delete system call (either via rm -f or cmd /c del) to
+# complete with success but the file can linger for seconds or even minutes
+# until it suddenly disappears. During this time, the file cannot be overwritten
+# but it can be renamed, hence the odd use of mktemp. Some tests compiled with
+# flambda seem to be consistently "interesting" to Windows Defender. Note that
+# the interference doesn't appear to affect the execution of the tests.
 .PHONY: run-file
 run-file:
        @printf " $(DESC)"
-       @rm -f program program.exe
+       @test -e program.exe && { \
+         T="`mktemp -p .`"; \
+         mv -f program.exe "$$T"; \
+         rm -f "$$T"; \
+       } || true
+       @rm -f program program$(EXE)
        @$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE)
        @F="`basename $(FILE) .ml`"; \
        if [ -f $$F.runner ]; then \
@@ -108,9 +123,15 @@ run-file:
        fi \
        && \
        if [ -f $$F.checker ]; then \
-         DIFF="$(DIFF)" SORT="$(SORT)" sh $$F.checker; \
+         DIFF="$(DIFF)" SORT="$(SORT)" sh $$F.checker || { \
+           printf "  Error: output checker failed!\n"; \
+           exit 1; \
+         }; \
        else \
-         $(DIFF) $$F.reference $$F.result >/dev/null; \
+         $(DIFF) $$F.reference $$F.result >/dev/null || { \
+           printf "  Error: results don't match reference output!\n"; \
+           exit 1; \
+         }; \
        fi
 
 .PHONY: promote
@@ -118,4 +139,4 @@ promote: defaultpromote
 
 .PHONY: clean
 clean: defaultclean
-       @rm -f *.result program program.exe
+       @rm -f *.result program program.exe $(GENERATED_SOURCES)

diff --git a/testsuite/tests/array-functions/test.ml b/testsuite/tests/array-functions/test.ml
index 5a6f810f453189b72a07a9a83dbd46a77348ed48..e325724cce2bf17491fca91d4bfcc297b489b624 100644 (file)
--- a/testsuite/tests/array-functions/test.ml
+++ b/testsuite/tests/array-functions/test.ml
@@ -26,7 +26,7 @@ let () =
   assert (not (Array.exists (fun a -> a mod 2 = 0)  [|1;3;5|]));
   assert (not (Array.exists (fun _ -> true) [||]));
   assert (Array.exists (fun a -> a.(9) = 1) (Array.make_matrix 10 10 1));
-  let f = Array.make_float 10 in
+  let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
   assert (Array.exists (fun a -> a = 1.0) f);
 ;;
@@ -99,7 +99,7 @@ let () =
   assert (not (Array.for_all (fun x -> x mod 2 = 0) [|2;3;6|]));
   assert (Array.for_all (fun _ -> false) [||]);
   assert (Array.for_all (fun a -> a.(9) = 1) (Array.make_matrix 10 10 1));
-  let f = Array.make_float 10 in
+  let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
   assert (Array.for_all (fun a -> a = 1.0) f);
 ;;
@@ -147,7 +147,7 @@ let () =
   assert (Array.mem [|1;2;3|] [|[|1;2;3|];[|2;3;4|];[|0|]|]);
   assert (Array.mem 1 (Array.make 100 1));
   assert (Array.mem (ref 1) (Array.make 100 (ref 1)));
-  let f = Array.make_float 10 in
+  let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
   assert (Array.mem 1.0 f);
 ;;
@@ -174,7 +174,7 @@ let () =
   assert (not (Array.memq [|1;2;3|] [|[|1;2;3|];[|2;3;4|];[|0|]|]));
   assert (Array.memq 1 (Array.make 100 1));
   assert (not (Array.memq (ref 1) (Array.make 100 (ref 1))));
-  let f = Array.make_float 10 in
+  let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
   assert (not (Array.memq 1.0 f));
 ;;

diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile
index 212f4112f74630db44befb7be61f4eacfb563d07..abcb8729668bb3d42c099097517cf3a023c4e501 100644 (file)
--- a/testsuite/tests/asmcomp/Makefile
+++ b/testsuite/tests/asmcomp/Makefile
@@ -18,6 +18,7 @@ BASEDIR=../..
 INCLUDES=\
   -I $(OTOPDIR)/utils \
   -I $(OTOPDIR)/typing \
+  -I $(OTOPDIR)/middle_end \
   -I $(OTOPDIR)/bytecomp \
   -I $(OTOPDIR)/asmcomp
 
@@ -47,10 +48,17 @@ parsecmm.mli parsecmm.ml: parsecmm.mly
 lexcmm.ml: lexcmm.mll
        @$(OCAMLLEX) -q lexcmm.mll
 
-MLCASES=optargs staticalloc bind_tuples is_static register_typing
+MLCASES=optargs staticalloc bind_tuples is_static register_typing \
+  register_typing_switch
 ARGS_is_static=-I $(OTOPDIR)/byterun is_in_static_data.c
-MLCASES_FLAMBDA=is_static_flambda unrolling_flambda
-ARGS_is_static_flambda=-I $(OTOPDIR)/byterun is_in_static_data.c
+MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2 \
+  static_float_array_flambda static_float_array_flambda_opaque
+ARGS_is_static_flambda=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c is_static_flambda_dep.ml
+ARGS_static_float_array_flambda=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c simple_float_const.ml
+ARGS_static_float_array_flambda_opaque=\
+  -I $(OTOPDIR)/byterun is_in_static_data.c -opaque simple_float_const_opaque.ml
 
 CASES=fib tak quicksort quicksort2 soli \
       arith checkbound tagged-fib tagged-integr tagged-quicksort tagged-tak
@@ -66,9 +74,10 @@ ARGS_tagged-fib=-DINT_INT -DFUN=fib main.c
 ARGS_tagged-integr=-DINT_FLOAT -DFUN=test main.c
 ARGS_tagged-quicksort=-DSORT -DFUN=quicksort main.c
 ARGS_tagged-tak=-DUNIT_INT -DFUN=takmain main.c
+ARGS_staticalloc=-I $(OTOPDIR)/utils config.cmx
 
 skips:
-       @for c in $(CASES) $(MLCASES); do \
+       @for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA); do \
          echo " ... testing '$$c': => skipped"; \
        done
 
@@ -81,7 +90,7 @@ one_ml_flambda:
           $(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
           ./$(NAME).exe && echo " => passed" || echo " => failed"; \
         else \
-          echo "=> skipped"; \
+          echo " => skipped"; \
         fi
 
 one:
@@ -102,6 +111,11 @@ else
 SKIP=false
 endif
 
+ifeq "$(WITH_SPACETIME)" "true"
+# These tests have not been ported for Spacetime
+SKIP=true
+endif
+
 ifeq ($(CCOMPTYPE),msvc)
 CC=set -o pipefail ; $(NATIVECC) $(CFLAGS) /Fe$(1) | tail -n +2
 CFLAGS=$(NATIVECCCOMPOPTS)

diff --git a/testsuite/tests/asmcomp/bind_tuples.ml b/testsuite/tests/asmcomp/bind_tuples.ml
index 503b3a34b274f80d7f92fd549f70336496575b1b..a6dd2947d12d5892dbe58e9b73b41e0fb5ecdc62 100755 (executable)
--- a/testsuite/tests/asmcomp/bind_tuples.ml
+++ b/testsuite/tests/asmcomp/bind_tuples.ml
@@ -1,24 +1,9 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Check the effectiveness of optimized compilation of tuple binding
 
    Ref: http://caml.inria.fr/mantis/view.php?id=4800
 *)
 
-let () =
+let f () =
   let x0 = Gc.allocated_bytes () in
   let x1 = Gc.allocated_bytes () in
 
@@ -38,3 +23,6 @@ let () =
   print_int !r;
   assert (!r = 82);
   assert(x1 -. x0 = x2 -. x1) (* check no allocation between x1 and x2 *)
+  [@@inline never]
+
+let () = f ()

diff --git a/testsuite/tests/asmcomp/is_static_flambda.ml b/testsuite/tests/asmcomp/is_static_flambda.ml
index 6766fb8df1202e83c0fbfedd59d2cc512678463a..d4cf27566e3536d7158553dee8358b57403b3d86 100644 (file)
--- a/testsuite/tests/asmcomp/is_static_flambda.ml
+++ b/testsuite/tests/asmcomp/is_static_flambda.ml
@@ -91,3 +91,25 @@ let () =
     try (failwith [@inlined always]) "some other string" with exn -> exn
   in
   assert(is_in_static_data exn)
+
+(* Verify that approximation intersection correctly loads exported
+   approximations.
+
+   Is_static_flambda_dep.pair is a pair with 1 as first element. The
+   intersection of approximations should return a block with
+   approximation: [tag 0: [tag 0: Int 1, Unknown], Unknown] *)
+let f x =
+  let pair =
+    if Sys.opaque_identity x then
+      (1, 2), 3
+    else
+      Is_static_flambda_dep.pair, 4
+  in
+  let n = fst (fst pair) in
+  let res = n, n in
+  assert(is_in_static_data res)
+  [@@inline never]
+
+let () =
+  f true;
+  f false

diff --git a/testsuite/tests/asmcomp/is_static_flambda_dep.ml b/testsuite/tests/asmcomp/is_static_flambda_dep.ml
new file mode 100644 (file)
index 0000000..3a50f7c
--- /dev/null
+++ b/testsuite/tests/asmcomp/is_static_flambda_dep.ml
@@ -0,0 +1 @@
+let pair = 1, 12

diff --git a/testsuite/tests/asmcomp/lexcmm.mli b/testsuite/tests/asmcomp/lexcmm.mli
index 18fdf7c0f6b687da1b035c69eca48fd08ce422b9..f9fe6afadf916e67e99cb31c99f2e802975644e8 100644 (file)
--- a/testsuite/tests/asmcomp/lexcmm.mli
+++ b/testsuite/tests/asmcomp/lexcmm.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 val token: Lexing.lexbuf -> Parsecmm.token
 
 type error =

diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll
index 6b985eb810bc625dbc35ab4304e53cc3049e34b2..d3c0d39477b047206feafc1ec3042c1ab97b11b3 100644 (file)
--- a/testsuite/tests/asmcomp/lexcmm.mll
+++ b/testsuite/tests/asmcomp/lexcmm.mll
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 {
 open Parsecmm
 
@@ -61,9 +46,8 @@ let keyword_table =
     "mulh", MULH;
     "or", OR;
     "proj", PROJ;
-    "raise", RAISE Lambda.Raise_regular;
-    "reraise", RAISE Lambda.Raise_reraise;
-    "raise_notrace", RAISE Lambda.Raise_notrace;
+    "raise_withtrace", RAISE Cmm.Raise_withtrace;
+    "raise_notrace", RAISE Cmm.Raise_notrace;
     "seq", SEQ;
     "signed", SIGNED;
     "skip", SKIP;

diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml
index 48ff1f77cd8ccbcf951867b4e24f2ade119cea0d..c094bd0962b0c3d40769bc7b5fbe61a61799d2d6 100644 (file)
--- a/testsuite/tests/asmcomp/main.ml
+++ b/testsuite/tests/asmcomp/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Clflags
 
 let compile_file filename =

diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c
index 492951b2cdf57d4c7e47afbbec0add6500662ce5..de876bfeadc5b2c5664c17a4be26d24a69d3d4f3 100644 (file)
--- a/testsuite/tests/asmcomp/mainarith.c
+++ b/testsuite/tests/asmcomp/mainarith.c
@@ -91,7 +91,7 @@ void do_test(void)
       INTTEST(R[15], (X - 1));
       INTTEST(R[16], (X - -1));
 
-      INTTEST(R[17], ((intnat) ((char *)R - 8)));
+      INTTEST(R[17], ((intnat) ((uintnat)R - 8)));
       INTTEST(R[18], ((intnat) ((char *)R - Y)));
 
       INTTEST(R[19], (X * 2));

diff --git a/testsuite/tests/asmcomp/optargs.ml b/testsuite/tests/asmcomp/optargs.ml
index 43982faf5dc3da273d11c9d0725d00f751731ab2..a4f40407037f8de88ce998dde4a8d00ab81bc3bf 100644 (file)
--- a/testsuite/tests/asmcomp/optargs.ml
+++ b/testsuite/tests/asmcomp/optargs.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Check the effectiveness of inlining the wrapper which fills in
    default values for optional arguments.
 

diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly
index c372abf42c1a08c0a94634faa53a5cfd36784fd9..a1eea39fd42cbd694a5fdef667e72cc480f1759d 100644 (file)
--- a/testsuite/tests/asmcomp/parsecmm.mly
+++ b/testsuite/tests/asmcomp/parsecmm.mly
@@ -1,18 +1,3 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                OCaml                                   */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 1996 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
 /* A simple parser for C-- */
 
 %{
@@ -113,7 +98,7 @@ let access_array base numelt size =
 %token OR
 %token <int> POINTER
 %token PROJ
-%token <Lambda.raise_kind> RAISE
+%token <Cmm.raise_kind> RAISE
 %token RBRACKET
 %token RPAREN
 %token SEQ
@@ -188,7 +173,7 @@ expr:
   | LPAREN APPLY expr exprlist machtype RPAREN
                 { Cop(Capply($5, Debuginfo.none), $3 :: List.rev $4) }
   | LPAREN EXTCALL STRING exprlist machtype RPAREN
-                { Cop(Cextcall($3, $5, false, Debuginfo.none), List.rev $4) }
+               {Cop(Cextcall($3, $5, false, Debuginfo.none, None), List.rev $4)}
   | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3]) }
   | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4]) }
   | LPAREN unaryop expr RPAREN { Cop($2, [$3]) }
@@ -253,7 +238,7 @@ chunk:
 ;
 unaryop:
     LOAD chunk                  { Cload $2 }
-  | ALLOC                       { Calloc }
+  | ALLOC                       { Calloc Debuginfo.none }
   | FLOATOFINT                  { Cfloatofint }
   | INTOFFLOAT                  { Cintoffloat }
   | RAISE                       { Craise ($1, Debuginfo.none) }
@@ -322,15 +307,12 @@ datalist:
 ;
 dataitem:
     STRING COLON                { Cdefine_symbol $1 }
-  | INTCONST COLON              { Cdefine_label $1 }
   | BYTE INTCONST               { Cint8 $2 }
   | HALF INTCONST               { Cint16 $2 }
   | INT INTCONST                { Cint(Nativeint.of_int $2) }
   | FLOAT FLOATCONST            { Cdouble (float_of_string $2) }
   | ADDR STRING                 { Csymbol_address $2 }
-  | ADDR INTCONST               { Clabel_address $2 }
   | VAL STRING                 { Csymbol_address $2 }
-  | VAL INTCONST               { Clabel_address $2 }
   | KSTRING STRING              { Cstring $2 }
   | SKIP INTCONST               { Cskip $2 }
   | ALIGN INTCONST              { Calign $2 }

diff --git a/testsuite/tests/asmcomp/parsecmmaux.ml b/testsuite/tests/asmcomp/parsecmmaux.ml
index b4671dfa1f808173167089a6a00669ee85b0d44d..d2199cbed3ab63845a72ada2f1bfc86587f55258 100644 (file)
--- a/testsuite/tests/asmcomp/parsecmmaux.ml
+++ b/testsuite/tests/asmcomp/parsecmmaux.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Auxiliary functions for parsing *)
 
 type error =

diff --git a/testsuite/tests/asmcomp/parsecmmaux.mli b/testsuite/tests/asmcomp/parsecmmaux.mli
index b219b96322bc505f6823f56d8af258d1b10177da..c7920803aef1bf8349f58a290ce7d0955567bf88 100644 (file)
--- a/testsuite/tests/asmcomp/parsecmmaux.mli
+++ b/testsuite/tests/asmcomp/parsecmmaux.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Auxiliary functions for parsing *)
 
 val bind_ident: string -> Ident.t

diff --git a/testsuite/tests/asmcomp/register_typing_switch.ml b/testsuite/tests/asmcomp/register_typing_switch.ml
new file mode 100644 (file)
index 0000000..18c4416
--- /dev/null
+++ b/testsuite/tests/asmcomp/register_typing_switch.ml
@@ -0,0 +1,21 @@
+type 'a typ = Int : int typ | Ptr : int list typ | Int2 : int typ
+
+let f (type a) (t : a typ) (p : int list) : a =
+  match t with
+  | Int -> 100
+  | Ptr -> p
+  | Int2 -> 200
+
+let allocate_garbage () =
+  for i = 0 to 100 do
+    ignore (Array.make 200 0.0)
+  done
+
+let g (t : int list typ) x =
+  Gc.minor ();
+  let x = f t ([x; x; x; x; x]) in
+  Gc.minor ();
+  allocate_garbage ();
+  ignore (String.length (String.concat " " (List.map string_of_int x)))
+
+let () = g Ptr 5

diff --git a/testsuite/tests/asmcomp/simple_float_const.ml b/testsuite/tests/asmcomp/simple_float_const.ml
new file mode 100644 (file)
index 0000000..1aca414
--- /dev/null
+++ b/testsuite/tests/asmcomp/simple_float_const.ml
@@ -0,0 +1 @@
+let f = 3.14

diff --git a/testsuite/tests/asmcomp/simple_float_const_opaque.ml b/testsuite/tests/asmcomp/simple_float_const_opaque.ml
new file mode 100644 (file)
index 0000000..1aca414
--- /dev/null
+++ b/testsuite/tests/asmcomp/simple_float_const_opaque.ml
@@ -0,0 +1 @@
+let f = 3.14

diff --git a/testsuite/tests/asmcomp/soli.cmm b/testsuite/tests/asmcomp/soli.cmm
index a30da9a2eb086e2d48ea495746f3aedb3c254984..c8ffc5d68444baddd91edf2c1843eb76981d7347 100644 (file)
--- a/testsuite/tests/asmcomp/soli.cmm
+++ b/testsuite/tests/asmcomp/soli.cmm
@@ -66,7 +66,7 @@
                                  (intaset (addraref "board" i1) j1 1)
                                  (intaset (addraref "board" i2) j2 2)
                                  (if (app "solve" (+ m 1) int)
-                                     (raise 0a)
+                                     (raise_notrace 0a)
                                    [])
                                  (intaset (addraref "board" i) j 2)
                                  (intaset (addraref "board" i1) j1 2)

diff --git a/testsuite/tests/asmcomp/static_float_array_flambda.ml b/testsuite/tests/asmcomp/static_float_array_flambda.ml
new file mode 100644 (file)
index 0000000..f60e530
--- /dev/null
+++ b/testsuite/tests/asmcomp/static_float_array_flambda.ml
@@ -0,0 +1,18 @@
+external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+
+let a = [|0.; 1.|]
+let f = 1.23
+let b = [|0.; f; f|]
+let g = Sys.opaque_identity 1.23
+let c = [|0.; g|]
+let d = [|0.; Simple_float_const.f|]
+
+let () = assert(is_in_static_data a)
+let () = assert(is_in_static_data f)
+let () = assert(is_in_static_data b)
+
+let () = assert(not (is_in_static_data c))
+(* In fact this one could be static by preallocating the array then
+   patching it when g is available *)
+
+let () = assert(is_in_static_data d)

diff --git a/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml b/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml
new file mode 100644 (file)
index 0000000..518f48b
--- /dev/null
+++ b/testsuite/tests/asmcomp/static_float_array_flambda_opaque.ml
@@ -0,0 +1,21 @@
+external is_in_static_data : 'a -> bool = "caml_is_in_static_data"
+
+let a = [|0.; 1.|]
+let f = 1.23
+let b = [|0.; f; f|]
+let g = Sys.opaque_identity 1.23
+let c = [|0.; g|]
+let d = [|0.; Simple_float_const_opaque.f|]
+
+let () = assert(is_in_static_data a)
+let () = assert(is_in_static_data f)
+let () = assert(is_in_static_data b)
+
+let () = assert(not (is_in_static_data c))
+(* In fact this one could be static by preallocating the array then
+   patching it when g is available *)
+
+let () = assert(not (is_in_static_data d))
+(* The dependency Simple_float_const_opaque is built with opaque,
+   hence the value of Simple_float_const_opaque.f cannot be known
+   preventing the static allocation of d *)

diff --git a/testsuite/tests/asmcomp/staticalloc.ml b/testsuite/tests/asmcomp/staticalloc.ml
index de85079727df5fa9244a7ee5e425fed3b497502b..2e7c9a165d46498e058633b7947466056d7b9e55 100644 (file)
--- a/testsuite/tests/asmcomp/staticalloc.ml
+++ b/testsuite/tests/asmcomp/staticalloc.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Check the effectiveness of structured constant propagation and
    static allocation.
 
@@ -28,7 +13,7 @@ let () =
   let g () = (a, fst b) in
   assert (g () == ((1,2), (1,2)));
   assert (fst (pair a a) == (1, 2));
-  assert (snd b != ["x"; "y"]);  (* mutable "constant", cannot be shared *)
+  assert (snd b != ["x"; "y"] || Config.safe_string);  (* mutable "constant", cannot be shared *)
   let x2 = Gc.allocated_bytes () in
   assert(x1 -. x0 = x2 -. x1)
      (* check that we did not allocated anything between x1 and x2 *)

diff --git a/testsuite/tests/asmcomp/unrolling_flambda2.ml b/testsuite/tests/asmcomp/unrolling_flambda2.ml
new file mode 100644 (file)
index 0000000..cccda47
--- /dev/null
+++ b/testsuite/tests/asmcomp/unrolling_flambda2.ml
@@ -0,0 +1,20 @@
+
+type t = { fn : t -> t -> int -> unit -> unit }
+
+let rec foo f b n x =
+  if n < 0 then ()
+  else begin
+    foo f b (n - 1) x;
+    b.fn f b (n - 1) x
+  end
+[@@specialise always]
+
+let rec bar f b n x =
+  if n < 0 then ()
+  else begin
+    bar f b (n - 1) x;
+    f.fn f b (n - 1) x
+  end
+[@@specialise always]
+
+let () = foo {fn = foo} {fn = bar} 10 ()

diff --git a/testsuite/tests/ast-invariants/test.ml b/testsuite/tests/ast-invariants/test.ml
index b5c4ea21ff05a5935b3a0a7ae402a2170c1be07b..21e5e8c45b443439d8845104bccb44923de5a413 100644 (file)
--- a/testsuite/tests/ast-invariants/test.ml
+++ b/testsuite/tests/ast-invariants/test.ml
@@ -1,22 +1,8 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*                 Jeremie Dimino, Jane Street Europe                  *)
-(*                                                                     *)
-(*  Copyright 2015 Jane Street Group LLC                               *)
-(*                                                                     *)
-(*  All rights reserved.  This file is distributed under the terms of  *)
-(*  the GNU Lesser General Public License version 2.1, with the        *)
-(*  special exception on linking described in the file ../LICENSE.     *)
-(*                                                                     *)
-(***********************************************************************)
-
 (* This test checks all ml files in the ocaml repository that are accepted
    by the parser satisfy [Ast_invariants].
 
    We don't check the invariants on the output of the parser, so this test
-   is to ensure that we the parser doesn't accept more than [Ast_invariants].
+   is to ensure that the parser doesn't accept more than [Ast_invariants].
 *)
 
 let root = "../../.."

diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile
index 7566c193798d7642579933be04d20ec9d3125f5e..5df19fc6951d745527ce2ff11355e0d5f3a383ff 100644 (file)
--- a/testsuite/tests/backtrace/Makefile
+++ b/testsuite/tests/backtrace/Makefile
@@ -19,9 +19,14 @@ EXECNAME=program$(EXE)
 ABCDFILES=backtrace.ml
 OTHERFILES=backtrace2.ml backtrace3.ml raw_backtrace.ml \
            backtrace_deprecated.ml backtrace_slots.ml
+INLININGFILES=inline_test.ml inline_traversal_test.ml
 OTHERFILESNOINLINING=pr6920_why_at.ml pr6920_why_swallow.ml
 OTHERFILESNOINLINING_NATIVE=backtraces_and_finalizers.ml
 
+# Keep only filenames, lines and character ranges
+LOCATIONFILTER=grep -oE \
+               '[a-zA-Z_]+\.ml(:[0-9]+)?|(line|characters) [0-9-]+'
+
 default:
        @$(MAKE) byte
        @if $(BYTECODE_ONLY); then $(MAKE) skip ; else $(MAKE) native; fi
@@ -37,7 +42,7 @@ byte:
            (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
               $(OCAMLRUN) $(EXECNAME) $$arg || true) \
                 >$$F.$$arg.byte.result 2>&1; \
-           $(DIFF) $$F.$$arg.reference $$F.$$arg.byte.result >/dev/null \
+           $(DIFF) $$F.$$arg.byte.reference $$F.$$arg.byte.result >/dev/null \
            && echo " => passed" || echo " => failed"; \
          done; \
        done
@@ -49,7 +54,19 @@ byte:
          (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
             $(OCAMLRUN) $(EXECNAME) $$arg || true) \
               >$$F.byte.result 2>&1; \
-         $(DIFF) $$F.reference $$F.byte.result >/dev/null \
+         $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
+         && echo " => passed" || echo " => failed"; \
+       done;
+       @for file in $(INLININGFILES); \
+       do \
+         rm -f program program.exe; \
+         $(OCAMLC) -g -o $(EXECNAME) $$file; \
+         printf " ... testing '$$file' with ocamlc:"; \
+         F="`basename $$file .ml`"; \
+         (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+         $(OCAMLRUN) $(EXECNAME) $$arg 2>&1 || true) \
+                       | $(LOCATIONFILTER) >$$F.byte.result 2>&1; \
+         $(DIFF) $$F.byte.reference $$F.byte.result >/dev/null \
          && echo " => passed" || echo " => failed"; \
        done
 
@@ -62,7 +79,7 @@ skip:
          done; \
        done
        @for file in $(OTHERFILES) $(OTHERFILESNOINLINING) \
-                    $(OTHERFILESNOINLINING_NATIVE); do \
+                    $(OTHERFILESNOINLINING_NATIVE) $(INLININGFILES); do \
          echo " ... testing '$$file' with ocamlopt: => skipped"; \
        done
 
@@ -77,7 +94,8 @@ native:
            (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
               ./$(EXECNAME) $$arg || true) \
                 >$$F.$$arg.native.result 2>&1; \
-           $(DIFF) $$F.$$arg.reference $$F.$$arg.native.result >/dev/null \
+           $(DIFF) $$F.$$arg.native.reference $$F.$$arg.native.result \
+                   >/dev/null \
            && echo " => passed" || echo " => failed"; \
          done; \
        done
@@ -89,7 +107,7 @@ native:
          (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
             ./$(EXECNAME) $$arg || true) \
               >$$F.native.result 2>&1; \
-         $(DIFF) $$F.reference $$F.native.result >/dev/null \
+         $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
          && echo " => passed" || echo " => failed"; \
        done;
        @for file in $(OTHERFILESNOINLINING) $(OTHERFILESNOINLINING_NATIVE); \
@@ -101,10 +119,32 @@ native:
          (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
             ./$(EXECNAME) $$arg || true) \
               >$$F.native.result 2>&1; \
-         $(DIFF) $$F.reference $$F.native.result >/dev/null \
+         $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
+         && echo " => passed" || echo " => failed"; \
+       done;
+       @for file in $(INLININGFILES); \
+       do \
+         rm -f program program.exe; \
+         $(OCAMLOPT) -g -o $(EXECNAME) $$file; \
+         printf " ... testing '$$file' with ocamlopt:"; \
+         F="`basename $$file .ml`"; \
+         (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+         ./$(EXECNAME) $$arg 2>&1 || true) \
+                       | $(LOCATIONFILTER) >$$F.native.result; \
+         $(DIFF) $$F.native.reference $$F.native.result >/dev/null \
+         && echo " => passed" || echo " => failed"; \
+         rm -f program program.exe; \
+         $(OCAMLOPT) -g -o $(EXECNAME) -O3 $$file; \
+         printf " ... testing '$$file' with ocamlopt -O3:"; \
+         F="`basename $$file .ml`"; \
+         (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \
+         ./$(EXECNAME) $$arg 2>&1 || true) \
+                       | $(LOCATIONFILTER) >$$F.O3.result; \
+         $(DIFF) $$F.native.reference $$F.O3.result >/dev/null \
          && echo " => passed" || echo " => failed"; \
        done
 
+
 .PHONY: promote
 promote: defaultpromote
 

diff --git a/testsuite/tests/backtrace/backtrace..byte.reference b/testsuite/tests/backtrace/backtrace..byte.reference
new file mode 100644 (file)
index 0000000..d2d6933
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace..byte.reference
@@ -0,0 +1,2 @@
+Fatal error: exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24

diff --git a/testsuite/tests/backtrace/backtrace..native.reference b/testsuite/tests/backtrace/backtrace..native.reference
new file mode 100644 (file)
index 0000000..d2d6933
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace..native.reference
@@ -0,0 +1,2 @@
+Fatal error: exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24

diff --git a/testsuite/tests/backtrace/backtrace..reference b/testsuite/tests/backtrace/backtrace..reference
deleted file mode 100644 (file)
index d2d6933..0000000
--- a/testsuite/tests/backtrace/backtrace..reference
+++ /dev/null
@@ -1,2 +0,0 @@
-Fatal error: exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace.ml", line 18, characters 12-24

diff --git a/testsuite/tests/backtrace/backtrace.a.byte.reference b/testsuite/tests/backtrace/backtrace.a.byte.reference
new file mode 100644 (file)
index 0000000..7898192
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.a.byte.reference
@@ -0,0 +1 @@
+a

diff --git a/testsuite/tests/backtrace/backtrace.a.native.reference b/testsuite/tests/backtrace/backtrace.a.native.reference
new file mode 100644 (file)
index 0000000..7898192
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.a.native.reference
@@ -0,0 +1 @@
+a

diff --git a/testsuite/tests/backtrace/backtrace.a.reference b/testsuite/tests/backtrace/backtrace.a.reference
deleted file mode 100644 (file)
index 7898192..0000000
--- a/testsuite/tests/backtrace/backtrace.a.reference
+++ /dev/null
@@ -1 +0,0 @@
-a

diff --git a/testsuite/tests/backtrace/backtrace.b.byte.reference b/testsuite/tests/backtrace/backtrace.b.byte.reference
new file mode 100644 (file)
index 0000000..4737589
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.b.byte.reference
@@ -0,0 +1,11 @@
+b
+Fatal error: exception Backtrace.Error("b")
+Raised at file "backtrace.ml", line 7, characters 21-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Re-raised at file "backtrace.ml", line 13, characters 68-71
+Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace.b.native.reference b/testsuite/tests/backtrace/backtrace.b.native.reference
new file mode 100644 (file)
index 0000000..f1e8da8
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.b.native.reference
@@ -0,0 +1,11 @@
+b
+Fatal error: exception Backtrace.Error("b")
+Raised at file "backtrace.ml", line 7, characters 16-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Re-raised at file "backtrace.ml", line 13, characters 62-71
+Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace.b.reference b/testsuite/tests/backtrace/backtrace.b.reference
deleted file mode 100644 (file)
index 4737589..0000000
--- a/testsuite/tests/backtrace/backtrace.b.reference
+++ /dev/null
@@ -1,11 +0,0 @@
-b
-Fatal error: exception Backtrace.Error("b")
-Raised at file "backtrace.ml", line 7, characters 21-32
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 11, characters 4-11
-Re-raised at file "backtrace.ml", line 13, characters 68-71
-Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace.c.byte.reference b/testsuite/tests/backtrace/backtrace.c.byte.reference
new file mode 100644 (file)
index 0000000..33cac47
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.c.byte.reference
@@ -0,0 +1,3 @@
+Fatal error: exception Backtrace.Error("c")
+Raised at file "backtrace.ml", line 14, characters 26-37
+Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace.c.native.reference b/testsuite/tests/backtrace/backtrace.c.native.reference
new file mode 100644 (file)
index 0000000..431cd54
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.c.native.reference
@@ -0,0 +1,3 @@
+Fatal error: exception Backtrace.Error("c")
+Raised at file "backtrace.ml", line 14, characters 20-37
+Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace.c.reference b/testsuite/tests/backtrace/backtrace.c.reference
deleted file mode 100644 (file)
index 33cac47..0000000
--- a/testsuite/tests/backtrace/backtrace.c.reference
+++ /dev/null
@@ -1,3 +0,0 @@
-Fatal error: exception Backtrace.Error("c")
-Raised at file "backtrace.ml", line 14, characters 26-37
-Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace.d.byte.reference b/testsuite/tests/backtrace/backtrace.d.byte.reference
new file mode 100644 (file)
index 0000000..9ba4682
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.d.byte.reference
@@ -0,0 +1,9 @@
+Fatal error: exception Backtrace.Error("d")
+Raised at file "backtrace.ml", line 7, characters 21-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace.d.native.reference b/testsuite/tests/backtrace/backtrace.d.native.reference
new file mode 100644 (file)
index 0000000..d074040
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace.d.native.reference
@@ -0,0 +1,9 @@
+Fatal error: exception Backtrace.Error("d")
+Raised at file "backtrace.ml", line 7, characters 16-32
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 7, characters 42-53
+Called from file "backtrace.ml", line 11, characters 4-11
+Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace.d.reference b/testsuite/tests/backtrace/backtrace.d.reference
deleted file mode 100644 (file)
index 9ba4682..0000000
--- a/testsuite/tests/backtrace/backtrace.d.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-Fatal error: exception Backtrace.Error("d")
-Raised at file "backtrace.ml", line 7, characters 21-32
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 7, characters 42-53
-Called from file "backtrace.ml", line 11, characters 4-11
-Called from file "backtrace.ml", line 18, characters 9-25

diff --git a/testsuite/tests/backtrace/backtrace2.byte.reference b/testsuite/tests/backtrace/backtrace2.byte.reference
new file mode 100644 (file)
index 0000000..82833fd
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace2.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 7, characters 21-32
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 11, characters 4-11
+Re-raised at file "backtrace2.ml", line 13, characters 68-71
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 14, characters 26-37
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 7, characters 21-32
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 11, characters 4-11
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace2.native.reference b/testsuite/tests/backtrace/backtrace2.native.reference
new file mode 100644 (file)
index 0000000..5c75a66
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace2.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace2.Error("b")
+Raised at file "backtrace2.ml", line 7, characters 16-32
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 11, characters 4-11
+Re-raised at file "backtrace2.ml", line 13, characters 62-71
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Backtrace2.Error("c")
+Raised at file "backtrace2.ml", line 14, characters 20-37
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Backtrace2.Error("d")
+Raised at file "backtrace2.ml", line 7, characters 16-32
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 7, characters 42-53
+Called from file "backtrace2.ml", line 11, characters 4-11
+Called from file "backtrace2.ml", line 18, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace2.reference b/testsuite/tests/backtrace/backtrace2.reference
deleted file mode 100644 (file)
index 82833fd..0000000
--- a/testsuite/tests/backtrace/backtrace2.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 7, characters 21-32
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 11, characters 4-11
-Re-raised at file "backtrace2.ml", line 13, characters 68-71
-Called from file "backtrace2.ml", line 18, characters 11-23
-Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 14, characters 26-37
-Called from file "backtrace2.ml", line 18, characters 11-23
-Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 7, characters 21-32
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 11, characters 4-11
-Called from file "backtrace2.ml", line 18, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace3.byte.reference b/testsuite/tests/backtrace/backtrace3.byte.reference
new file mode 100644 (file)
index 0000000..5081640
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace3.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace3.Error("b")
+Raised at file "backtrace3.ml", line 7, characters 21-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Re-raised at file "backtrace3.ml", line 20, characters 47-50
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("c")
+Raised at file "backtrace3.ml", line 24, characters 12-23
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("d")
+Raised at file "backtrace3.ml", line 7, characters 21-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace3.native.reference b/testsuite/tests/backtrace/backtrace3.native.reference
new file mode 100644 (file)
index 0000000..c38a51e
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace3.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace3.Error("b")
+Raised at file "backtrace3.ml", line 7, characters 16-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Re-raised at file "backtrace3.ml", line 20, characters 41-50
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("c")
+Raised at file "backtrace3.ml", line 24, characters 6-23
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Backtrace3.Error("d")
+Raised at file "backtrace3.ml", line 7, characters 16-32
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 7, characters 42-53
+Called from file "backtrace3.ml", line 11, characters 4-11
+Called from file "backtrace3.ml", line 28, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace3.reference b/testsuite/tests/backtrace/backtrace3.reference
deleted file mode 100644 (file)
index 5081640..0000000
--- a/testsuite/tests/backtrace/backtrace3.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace3.Error("b")
-Raised at file "backtrace3.ml", line 7, characters 21-32
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 11, characters 4-11
-Re-raised at file "backtrace3.ml", line 20, characters 47-50
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Backtrace3.Error("c")
-Raised at file "backtrace3.ml", line 24, characters 12-23
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Backtrace3.Error("d")
-Raised at file "backtrace3.ml", line 7, characters 21-32
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 7, characters 42-53
-Called from file "backtrace3.ml", line 11, characters 4-11
-Called from file "backtrace3.ml", line 28, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace3.ml", line 28, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace_deprecated.byte.reference b/testsuite/tests/backtrace/backtrace_deprecated.byte.reference
new file mode 100644 (file)
index 0000000..e3eee3d
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_deprecated.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_deprecated.Error("b")
+Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Re-raised at file "backtrace_deprecated.ml", line 16, characters 68-71
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("c")
+Raised at file "backtrace_deprecated.ml", line 17, characters 26-37
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("d")
+Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace_deprecated.native.reference b/testsuite/tests/backtrace/backtrace_deprecated.native.reference
new file mode 100644 (file)
index 0000000..8d6826e
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_deprecated.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_deprecated.Error("b")
+Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Re-raised at file "backtrace_deprecated.ml", line 16, characters 62-71
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("c")
+Raised at file "backtrace_deprecated.ml", line 17, characters 20-37
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Backtrace_deprecated.Error("d")
+Raised at file "backtrace_deprecated.ml", line 10, characters 16-32
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 10, characters 42-53
+Called from file "backtrace_deprecated.ml", line 14, characters 4-11
+Called from file "backtrace_deprecated.ml", line 21, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace_deprecated.reference b/testsuite/tests/backtrace/backtrace_deprecated.reference
deleted file mode 100644 (file)
index e3eee3d..0000000
--- a/testsuite/tests/backtrace/backtrace_deprecated.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace_deprecated.Error("b")
-Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 14, characters 4-11
-Re-raised at file "backtrace_deprecated.ml", line 16, characters 68-71
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Backtrace_deprecated.Error("c")
-Raised at file "backtrace_deprecated.ml", line 17, characters 26-37
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Backtrace_deprecated.Error("d")
-Raised at file "backtrace_deprecated.ml", line 10, characters 21-32
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 10, characters 42-53
-Called from file "backtrace_deprecated.ml", line 14, characters 4-11
-Called from file "backtrace_deprecated.ml", line 21, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace_deprecated.ml", line 21, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace_slots.byte.reference b/testsuite/tests/backtrace/backtrace_slots.byte.reference
new file mode 100644 (file)
index 0000000..bfd8f5f
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_slots.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_slots.Error("b")
+Raised at file "backtrace_slots.ml", line 36, characters 21-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Re-raised at file "backtrace_slots.ml", line 42, characters 68-71
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("c")
+Raised at file "backtrace_slots.ml", line 43, characters 26-37
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("d")
+Raised at file "backtrace_slots.ml", line 36, characters 21-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace_slots.native.reference b/testsuite/tests/backtrace/backtrace_slots.native.reference
new file mode 100644 (file)
index 0000000..dd47e69
--- /dev/null
+++ b/testsuite/tests/backtrace/backtrace_slots.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Backtrace_slots.Error("b")
+Raised at file "backtrace_slots.ml", line 36, characters 16-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Re-raised at file "backtrace_slots.ml", line 42, characters 62-71
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("c")
+Raised at file "backtrace_slots.ml", line 43, characters 20-37
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Backtrace_slots.Error("d")
+Raised at file "backtrace_slots.ml", line 36, characters 16-32
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 36, characters 42-53
+Called from file "backtrace_slots.ml", line 40, characters 4-11
+Called from file "backtrace_slots.ml", line 47, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22

diff --git a/testsuite/tests/backtrace/backtrace_slots.reference b/testsuite/tests/backtrace/backtrace_slots.reference
deleted file mode 100644 (file)
index bfd8f5f..0000000
--- a/testsuite/tests/backtrace/backtrace_slots.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Backtrace_slots.Error("b")
-Raised at file "backtrace_slots.ml", line 36, characters 21-32
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 40, characters 4-11
-Re-raised at file "backtrace_slots.ml", line 42, characters 68-71
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Backtrace_slots.Error("c")
-Raised at file "backtrace_slots.ml", line 43, characters 26-37
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Backtrace_slots.Error("d")
-Raised at file "backtrace_slots.ml", line 36, characters 21-32
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 36, characters 42-53
-Called from file "backtrace_slots.ml", line 40, characters 4-11
-Called from file "backtrace_slots.ml", line 47, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace_slots.ml", line 47, characters 14-22

diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference
new file mode 100644 (file)
index 0000000..9766475
--- /dev/null
+++ b/testsuite/tests/backtrace/backtraces_and_finalizers.native.reference
@@ -0,0 +1 @@
+ok

diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.reference
deleted file mode 100644 (file)
index 9766475..0000000
--- a/testsuite/tests/backtrace/backtraces_and_finalizers.reference
+++ /dev/null
@@ -1 +0,0 @@
-ok

diff --git a/testsuite/tests/backtrace/inline_test.byte.reference b/testsuite/tests/backtrace/inline_test.byte.reference
new file mode 100644 (file)
index 0000000..0cda2ef
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.byte.reference
@@ -0,0 +1,15 @@
+inline_test.ml
+line 5
+characters 8-24
+inline_test.ml
+line 8
+characters 2-5
+inline_test.ml
+line 11
+characters 12-17
+inline_test.ml
+line 14
+characters 5-8
+inline_test.ml
+line 18
+characters 2-6

diff --git a/testsuite/tests/backtrace/inline_test.ml b/testsuite/tests/backtrace/inline_test.ml
new file mode 100644 (file)
index 0000000..ae64e2c
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.ml
@@ -0,0 +1,18 @@
+
+(* A test for inlined stack backtraces *)
+
+let f x =
+  raise (Failure "test") + 1
+
+let g x =
+  f x + 1
+
+let h x =
+  print_int (g x); print_endline "h"
+
+let i x =
+  if h x = () then ()
+
+let () =
+  Printexc.record_backtrace true;
+  i ()

diff --git a/testsuite/tests/backtrace/inline_test.native.reference b/testsuite/tests/backtrace/inline_test.native.reference
new file mode 100644 (file)
index 0000000..644987b
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_test.native.reference
@@ -0,0 +1,15 @@
+inline_test.ml
+line 5
+characters 2-24
+inline_test.ml
+line 8
+characters 2-5
+inline_test.ml
+line 11
+characters 12-17
+inline_test.ml
+line 14
+characters 5-8
+inline_test.ml
+line 18
+characters 2-6

diff --git a/testsuite/tests/backtrace/inline_traversal_test.byte.reference b/testsuite/tests/backtrace/inline_traversal_test.byte.reference
new file mode 100644 (file)
index 0000000..bcb98c3
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.byte.reference
@@ -0,0 +1,5 @@
+inline_traversal_test.ml:5
+inline_traversal_test.ml:8
+inline_traversal_test.ml:11
+inline_traversal_test.ml:14
+inline_traversal_test.ml:19

diff --git a/testsuite/tests/backtrace/inline_traversal_test.ml b/testsuite/tests/backtrace/inline_traversal_test.ml
new file mode 100644 (file)
index 0000000..1d91844
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.ml
@@ -0,0 +1,46 @@
+
+(* A test for inlined stack backtraces *)
+
+let f x =
+  raise (Failure "test") + 1
+
+let g x =
+  f x + 1
+
+let h x =
+  print_int (g x); print_endline "h"
+
+let i x =
+  if h x = () then ()
+
+let () =
+  let open Printexc in
+  record_backtrace true;
+  try i ()
+  with _ ->
+    let trace = get_raw_backtrace () in
+    let print_slot slot =
+      let x = convert_raw_backtrace_slot slot in
+      let is_raise = Slot.is_raise x in
+      let is_inline = Slot.is_inline x in
+      let location = match Slot.location x with
+        | None -> "<unknown>"
+        | Some {filename; line_number; _} ->
+            filename ^ ":" ^ string_of_int line_number
+      in
+      Printf.printf "- %s%s%s\n"
+        location
+        (if is_inline then " inlined" else "")
+        (if is_raise then ", raise" else "")
+    in
+    let rec print_slots = function
+      | None -> ()
+      | Some slot ->
+        print_slot slot;
+        print_slots (get_raw_backtrace_next_slot slot)
+    in
+    for i = 0 to raw_backtrace_length trace - 1 do
+      let slot = get_raw_backtrace_slot trace i in
+      Printf.printf "Frame %d\n" i;
+      print_slots (Some slot)
+    done

diff --git a/testsuite/tests/backtrace/inline_traversal_test.native.reference b/testsuite/tests/backtrace/inline_traversal_test.native.reference
new file mode 100644 (file)
index 0000000..bcb98c3
--- /dev/null
+++ b/testsuite/tests/backtrace/inline_traversal_test.native.reference
@@ -0,0 +1,5 @@
+inline_traversal_test.ml:5
+inline_traversal_test.ml:8
+inline_traversal_test.ml:11
+inline_traversal_test.ml:14
+inline_traversal_test.ml:19

diff --git a/testsuite/tests/backtrace/pr6920_why_at.byte.reference b/testsuite/tests/backtrace/pr6920_why_at.byte.reference
new file mode 100644 (file)
index 0000000..dcc2fcc
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_at.byte.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_at.ml", line 1, characters 41-45
+Called from file "pr6920_why_at.ml", line 3, characters 2-11
+Called from file "pr6920_why_at.ml", line 9, characters 2-6

diff --git a/testsuite/tests/backtrace/pr6920_why_at.native.reference b/testsuite/tests/backtrace/pr6920_why_at.native.reference
new file mode 100644 (file)
index 0000000..057c389
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_at.native.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_at.ml", line 1, characters 35-45
+Called from file "pr6920_why_at.ml", line 3, characters 2-11
+Called from file "pr6920_why_at.ml", line 9, characters 2-6

diff --git a/testsuite/tests/backtrace/pr6920_why_at.reference b/testsuite/tests/backtrace/pr6920_why_at.reference
deleted file mode 100644 (file)
index dcc2fcc..0000000
--- a/testsuite/tests/backtrace/pr6920_why_at.reference
+++ /dev/null
@@ -1,4 +0,0 @@
-Fatal error: exception Pervasives.Exit
-Raised at file "pr6920_why_at.ml", line 1, characters 41-45
-Called from file "pr6920_why_at.ml", line 3, characters 2-11
-Called from file "pr6920_why_at.ml", line 9, characters 2-6

diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
new file mode 100644 (file)
index 0000000..ad66532
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_swallow.ml", line 1, characters 41-45
+Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
+Called from file "pr6920_why_swallow.ml", line 11, characters 2-6

diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.native.reference b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
new file mode 100644 (file)
index 0000000..facb06d
--- /dev/null
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
@@ -0,0 +1,4 @@
+Fatal error: exception Pervasives.Exit
+Raised at file "pr6920_why_swallow.ml", line 1, characters 35-45
+Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
+Called from file "pr6920_why_swallow.ml", line 11, characters 2-6

diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.reference b/testsuite/tests/backtrace/pr6920_why_swallow.reference
deleted file mode 100644 (file)
index ad66532..0000000
--- a/testsuite/tests/backtrace/pr6920_why_swallow.reference
+++ /dev/null
@@ -1,4 +0,0 @@
-Fatal error: exception Pervasives.Exit
-Raised at file "pr6920_why_swallow.ml", line 1, characters 41-45
-Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
-Called from file "pr6920_why_swallow.ml", line 11, characters 2-6

diff --git a/testsuite/tests/backtrace/raw_backtrace.byte.reference b/testsuite/tests/backtrace/raw_backtrace.byte.reference
new file mode 100644 (file)
index 0000000..b936523
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.byte.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 11, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 13, characters 68-71
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 14, characters 26-37
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 11, characters 4-11
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22

diff --git a/testsuite/tests/backtrace/raw_backtrace.native.reference b/testsuite/tests/backtrace/raw_backtrace.native.reference
new file mode 100644 (file)
index 0000000..b1ff607
--- /dev/null
+++ b/testsuite/tests/backtrace/raw_backtrace.native.reference
@@ -0,0 +1,27 @@
+a
+No exception
+b
+Uncaught exception Raw_backtrace.Error("b")
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 11, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 13, characters 62-71
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Raw_backtrace.Error("c")
+Raised at file "raw_backtrace.ml", line 14, characters 20-37
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Raw_backtrace.Error("d")
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 11, characters 4-11
+Called from file "raw_backtrace.ml", line 18, characters 11-23
+Uncaught exception Invalid_argument("index out of bounds")
+Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22

diff --git a/testsuite/tests/backtrace/raw_backtrace.reference b/testsuite/tests/backtrace/raw_backtrace.reference
deleted file mode 100644 (file)
index b936523..0000000
--- a/testsuite/tests/backtrace/raw_backtrace.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-a
-No exception
-b
-Uncaught exception Raw_backtrace.Error("b")
-Raised at file "raw_backtrace.ml", line 7, characters 21-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 11, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 13, characters 68-71
-Called from file "raw_backtrace.ml", line 18, characters 11-23
-Uncaught exception Raw_backtrace.Error("c")
-Raised at file "raw_backtrace.ml", line 14, characters 26-37
-Called from file "raw_backtrace.ml", line 18, characters 11-23
-Uncaught exception Raw_backtrace.Error("d")
-Raised at file "raw_backtrace.ml", line 7, characters 21-32
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 11, characters 4-11
-Called from file "raw_backtrace.ml", line 18, characters 11-23
-Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22

diff --git a/testsuite/tests/basic-float/Makefile b/testsuite/tests/basic-float/Makefile
index a3fd7f642377d9d3b19ad131864db3b7b9f504d6..c11a415f745638e21ecfa11c3b99191c7549d854 100644 (file)
--- a/testsuite/tests/basic-float/Makefile
+++ b/testsuite/tests/basic-float/Makefile
@@ -14,8 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-MODULES=float_record float_array
-MAIN_MODULE=tfloat_record
-
-include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-float/float_array.ml b/testsuite/tests/basic-float/float_array.ml
deleted file mode 100644 (file)
index 8ec63b0..0000000
--- a/testsuite/tests/basic-float/float_array.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-let small_float_array x =
-  [|1.;2.;3.|], x
-
-let longer_float_array x =
-  [|1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
-    1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
-    1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
-    1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;|], x

diff --git a/testsuite/tests/basic-float/float_record.ml b/testsuite/tests/basic-float/float_record.ml
deleted file mode 100644 (file)
index 6bbbd3f..0000000
--- a/testsuite/tests/basic-float/float_record.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-type t = float;;
-
-let make f = f;;
-
-let from t = t;;
-
-type s = {f : t};;

diff --git a/testsuite/tests/basic-float/float_record.mli b/testsuite/tests/basic-float/float_record.mli
deleted file mode 100644 (file)
index b3f69ae..0000000
--- a/testsuite/tests/basic-float/float_record.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-type t = private float;;
-
-val make : float -> t;;
-val from : t -> float;;
-
-type s = {f : t};;

diff --git a/testsuite/tests/basic-float/tfloat_hex.ml b/testsuite/tests/basic-float/tfloat_hex.ml
new file mode 100644 (file)
index 0000000..995d50c
--- /dev/null
+++ b/testsuite/tests/basic-float/tfloat_hex.ml
@@ -0,0 +1,15 @@
+let try_float_of_string str =
+  try
+    print_float (float_of_string str);
+    print_newline ()
+  with exn ->
+    print_endline (Printexc.to_string exn)
+;;
+
+let () =
+  try_float_of_string "0x1A";
+  try_float_of_string "0x1Ap3";
+  try_float_of_string "0x";
+  try_float_of_string "0x.";
+  try_float_of_string "0xp0";
+  try_float_of_string "0x.p0";

diff --git a/testsuite/tests/basic-float/tfloat_hex.reference b/testsuite/tests/basic-float/tfloat_hex.reference
new file mode 100644 (file)
index 0000000..9fce15f
--- /dev/null
+++ b/testsuite/tests/basic-float/tfloat_hex.reference
@@ -0,0 +1,6 @@
+26.
+208.
+Failure("float_of_string")
+Failure("float_of_string")
+Failure("float_of_string")
+Failure("float_of_string")

diff --git a/testsuite/tests/basic-float/tfloat_record.ml b/testsuite/tests/basic-float/tfloat_record.ml
index 12ab9a5258c8a5d3d35fd739e7a988a07866f3ab..38cf230baf9b607f1c6a73f21ef89338fa831458 100644 (file)
--- a/testsuite/tests/basic-float/tfloat_record.ml
+++ b/testsuite/tests/basic-float/tfloat_record.ml
@@ -1,17 +1,30 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
+module Float_record : sig
+  type t = private float;;
+
+  val make : float -> t;;
+  val from : t -> float;;
+
+  type s = {f : t};;
+end = struct
+  type t = float;;
+
+  let make f = f;;
+
+  let from t = t;;
+
+  type s = {f : t};;
+end
+
+module Float_array = struct
+  let small_float_array x =
+    [|1.;2.;3.|], x
+
+  let longer_float_array x =
+    [|1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;
+      1.;2.;3.;4.;5.;6.;7.;8.;9.;0.;|], x
+end
 
 let s = { Float_record.f = Float_record.make 1.0 };;
 

diff --git a/testsuite/tests/basic-io-2/io.ml b/testsuite/tests/basic-io-2/io.ml
index bad6c4f4c7f4ac5d8f23b275a2e6be3ac461e672..3c088d3f5d198f32d9e3d9790e3a1f8d5c535f2f 100644 (file)
--- a/testsuite/tests/basic-io-2/io.ml
+++ b/testsuite/tests/basic-io-2/io.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test a file copy function *)
 
 let test msg funct f1 f2 =

diff --git a/testsuite/tests/basic-manyargs/manyargs.ml b/testsuite/tests/basic-manyargs/manyargs.ml
index f8b39ad15e9a6792ea0839ab22ce6eb15d5bd51a..352f3cfa78bf3bcda0af83287a52a97578ed9f2d 100644 (file)
--- a/testsuite/tests/basic-manyargs/manyargs.ml
+++ b/testsuite/tests/basic-manyargs/manyargs.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let manyargs a b c d e f g h i j k l m n o =
   print_string "a = "; print_int a; print_newline();
   print_string "b = "; print_int b; print_newline();

diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml
index d49acbd38ee81187da355867b33b6e9ce1f9278f..7f3f44d72b7149126ae2e4c51e9655a6b3557ce1 100644 (file)
--- a/testsuite/tests/basic-modules/main.ml
+++ b/testsuite/tests/basic-modules/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*               Jacques Garrigue, Nagoya University                      *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* PR#6435 *)
 
 module F (M : sig

diff --git a/testsuite/tests/basic-modules/offset.ml b/testsuite/tests/basic-modules/offset.ml
index 0b2a8d6fb19891ee2aa2c60f2cd3b8f8849527a1..457947dcd5bdcca9f44002873c7b3a1158fc406c 100644 (file)
--- a/testsuite/tests/basic-modules/offset.ml
+++ b/testsuite/tests/basic-modules/offset.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*               Jacques Garrigue, Nagoya University                      *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module M = struct
  type t = string
 

diff --git a/testsuite/tests/basic-modules/pr6726.ml b/testsuite/tests/basic-modules/pr6726.ml
index 16d12b1e9815cb08b4a5fa2799fa23bff2ab6204..7b50350183f98167a7ee540341a8e28ada33e2a5 100644 (file)
--- a/testsuite/tests/basic-modules/pr6726.ml
+++ b/testsuite/tests/basic-modules/pr6726.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*               Jacques Garrigue, Nagoya University                      *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module ExtUnixAll = struct
  external unused : unit -> unit = "caml_blit_string"
  module BigEndian = struct

diff --git a/testsuite/tests/basic-more/bounds.ml b/testsuite/tests/basic-more/bounds.ml
index 4285964ba818fbeefd1db9b60ab1dc15a7e3737f..edaa0c8a2cea0b97e7715e842d395f53d5219ea7 100644 (file)
--- a/testsuite/tests/basic-more/bounds.ml
+++ b/testsuite/tests/basic-more/bounds.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1998 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test bound checks with ocamlopt *)
 
 let a = [| 0; 1; 2 |]

diff --git a/testsuite/tests/basic-more/div_by_zero.ml b/testsuite/tests/basic-more/div_by_zero.ml
new file mode 100644 (file)
index 0000000..9dc45e7
--- /dev/null
+++ b/testsuite/tests/basic-more/div_by_zero.ml
@@ -0,0 +1,67 @@
+
+let check f n =
+  assert (
+    try ignore ((Sys.opaque_identity f) n); false with
+      Division_by_zero -> true
+  )
+
+let div_int n  = n / 0
+let div_int32 n = Int32.div n 0l
+let div_int64 n = Int64.div n 0L
+let div_nativeint n = Nativeint.div n 0n
+
+let mod_int n  = n mod 0
+let mod_int32 n = Int32.rem n 0l
+let mod_int64 n = Int64.rem n 0L
+let mod_nativeint n = Nativeint.rem n 0n
+
+let div_int_opaque n  = n / (Sys.opaque_identity 0)
+let div_int32_opaque n = Int32.div n (Sys.opaque_identity 0l)
+let div_int64_opaque n = Int64.div n (Sys.opaque_identity 0L)
+let div_nativeint_opaque n = Nativeint.div n (Sys.opaque_identity 0n)
+
+let mod_int_opaque n  = n mod (Sys.opaque_identity 0)
+let mod_int32_opaque n = Int32.rem n (Sys.opaque_identity 0l)
+let mod_int64_opaque n = Int64.rem n (Sys.opaque_identity 0L)
+let mod_nativeint_opaque n = Nativeint.rem n (Sys.opaque_identity 0n)
+
+let () =
+  check div_int 33;
+  check div_int 0;
+  check div_int32 33l;
+  check div_int32 0l;
+  check div_int64 33L;
+  check div_int64 0L;
+  check div_nativeint 33n;
+  check div_nativeint 0n;
+
+  check mod_int 33;
+  check mod_int 0;
+  check mod_int32 33l;
+  check mod_int32 0l;
+  check mod_int64 33L;
+  check mod_int64 0L;
+  check mod_nativeint 33n;
+  check mod_nativeint 0n;
+
+  check div_int_opaque 33;
+  check div_int_opaque 0;
+  check div_int32_opaque 33l;
+  check div_int32_opaque 0l;
+  check div_int64_opaque 33L;
+  check div_int64_opaque 0L;
+  check div_nativeint_opaque 33n;
+  check div_nativeint_opaque 0n;
+
+  check mod_int_opaque 33;
+  check mod_int_opaque 0;
+  check mod_int32_opaque 33l;
+  check mod_int32_opaque 0l;
+  check mod_int64_opaque 33L;
+  check mod_int64_opaque 0L;
+  check mod_nativeint_opaque 33n;
+  check mod_nativeint_opaque 0n;
+  ()
+
+let () =
+  print_endline "***** OK *****"

diff --git a/testsuite/tests/basic-more/div_by_zero.reference b/testsuite/tests/basic-more/div_by_zero.reference
new file mode 100644 (file)
index 0000000..e6b9562
--- /dev/null
+++ b/testsuite/tests/basic-more/div_by_zero.reference
@@ -0,0 +1,3 @@
+***** OK *****
+
+All tests succeeded.

diff --git a/testsuite/tests/basic-more/morematch.ml b/testsuite/tests/basic-more/morematch.ml
index 7c5eb5028c3a607ac729ab97f26b4a519112bf37..86b638821ac8599b9cadd34a766db522b9fe7a6b 100644 (file)
--- a/testsuite/tests/basic-more/morematch.ml
+++ b/testsuite/tests/basic-more/morematch.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Luc Maranget, projet Moscova, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (**************************************************************)
 (*  This suite tests the pattern-matching compiler            *)
 (*  it should just compile and run.                           *)

diff --git a/testsuite/tests/basic-more/pr2719.ml b/testsuite/tests/basic-more/pr2719.ml
index fc8fd8839f9bf783640d6180edfaea0e378016db..f0a9d6a4f90f38bec195cae15edc3b76978bd483 100644 (file)
--- a/testsuite/tests/basic-more/pr2719.ml
+++ b/testsuite/tests/basic-more/pr2719.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 let bug () =

diff --git a/testsuite/tests/basic-more/pr6216.ml b/testsuite/tests/basic-more/pr6216.ml
index 97670487ab02ebba65a0046bb2ce98a467c9faa2..71844f1494d5bc97ea5ca87bbfd128ce4d50a2f4 100644 (file)
--- a/testsuite/tests/basic-more/pr6216.ml
+++ b/testsuite/tests/basic-more/pr6216.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*               Jacques Garrigue, Nagoya University                      *)
-(*                                                                        *)
-(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* PR6216: wrong inlining of GADT match *)
 
 type _ t =

diff --git a/testsuite/tests/basic-more/record_evaluation_order.ml b/testsuite/tests/basic-more/record_evaluation_order.ml
new file mode 100644 (file)
index 0000000..0e18af8
--- /dev/null
+++ b/testsuite/tests/basic-more/record_evaluation_order.ml
@@ -0,0 +1,89 @@
+
+type r =
+  { a : unit;
+    b : int;
+    c : char;
+    d : float; }
+
+let r1 =
+  {
+    c = (print_endline "c1"; 'c');
+    a = print_endline "a1";
+    d = (print_endline "d1"; 1.);
+    b = (print_endline "b1"; 2);
+  }
+
+let r2 =
+  {
+    b = (print_endline "b2"; 2);
+    d = (print_endline "d2"; 1.);
+    a = print_endline "a2";
+    c = (print_endline "c2"; 'c');
+  }
+
+let r3 =
+  { (print_endline "default"; r1) with
+    d = (print_endline "d3"; 1.);
+    c = (print_endline "c3"; 'c');
+    a = print_endline "a3";
+  }
+
+let () = print_endline ""
+
+type r2 =
+  { x1 : unit;
+    x2 : unit;
+    x3 : unit;
+    x4 : unit;
+    x5 : unit;
+    x6 : unit;
+    x7 : unit;
+    x8 : unit;
+    x9 : unit; }
+
+let a =
+  {
+    x5 = print_endline "x5";
+    x6 = print_endline "x6";
+    x1 = print_endline "x1";
+    x3 = print_endline "x3";
+    x4 = print_endline "x4";
+    x9 = print_endline "x9";
+    x7 = print_endline "x7";
+    x8 = print_endline "x8";
+    x2 = print_endline "x2";
+  }
+
+let () = print_endline ""
+
+let b =
+  { a with
+    x7 = print_endline "x7";
+    x2 = print_endline "x2";
+  }
+
+let () = print_endline ""
+
+let c =
+  { a with
+    x2 = print_endline "x2";
+    x7 = print_endline "x7";
+  }
+
+let () = print_endline ""
+
+let c =
+  { a with
+    x2 = print_endline "x2";
+    x7 = print_endline "x7";
+    x5 = print_endline "x5";
+  }
+
+let () = print_endline ""
+
+let d =
+  { a with
+    x5 = print_endline "x5";
+    x7 = print_endline "x7";
+    x2 = print_endline "x2";
+  }

diff --git a/testsuite/tests/basic-more/record_evaluation_order.reference b/testsuite/tests/basic-more/record_evaluation_order.reference
new file mode 100644 (file)
index 0000000..f418685
--- /dev/null
+++ b/testsuite/tests/basic-more/record_evaluation_order.reference
@@ -0,0 +1,38 @@
+d1
+c1
+b1
+a1
+d2
+c2
+b2
+a2
+default
+d3
+c3
+a3
+
+x9
+x8
+x7
+x6
+x5
+x4
+x3
+x2
+x1
+
+x7
+x2
+
+x7
+x2
+
+x7
+x5
+x2
+
+x7
+x5
+x2
+
+All tests succeeded.

diff --git a/testsuite/tests/basic-more/sequential_and_or.ml b/testsuite/tests/basic-more/sequential_and_or.ml
index 6218b5603d61cd6de13f7cc9563c940e6d7f9434..6492ea279e4314ba9032aa20820076c7a8c74ce3 100644 (file)
--- a/testsuite/tests/basic-more/sequential_and_or.ml
+++ b/testsuite/tests/basic-more/sequential_and_or.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                       Pierre Chambart, OCamlPro                        *)
-(*                                                                        *)
-(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let r = ref 0
 
 let true_effect () =
@@ -36,10 +21,10 @@ let () =
   s.[0] <- '\001'
 
 let unknown_true =
-  s.[0] = '\001'
+  Bytes.get s 0 = '\001'
 
 let unknown_false =
-  s.[0] <> '\001'
+  Bytes.get s 0 <> '\001'
 
 let () =
   test 1 (fun () -> true || true);

diff --git a/testsuite/tests/basic-more/structural_constants.ml b/testsuite/tests/basic-more/structural_constants.ml
new file mode 100644 (file)
index 0000000..4249e8c
--- /dev/null
+++ b/testsuite/tests/basic-more/structural_constants.ml
@@ -0,0 +1,217 @@
+
+type t1 =
+  | A | B | C of t1 | D of float
+
+let a = [A; B; C A; C (C A); D 1.234]
+let () =
+  match Sys.opaque_identity a with
+  | [A; B; C A; C (C A); D 1.234] -> ()
+  | _ -> assert false
+
+let () =
+  match a with
+  | [A; B; C A; C (C A); D 1.234] -> ()
+  | _ -> assert false
+
+let b = [|A; B; C A; C (C A); D 1.234|]
+let () =
+  match Sys.opaque_identity b with
+  | [|A; B; C A; C (C A); D 1.234|] -> ()
+  | _ -> assert false
+
+let () =
+  match b with
+  | [|A; B; C A; C (C A); D 1.234|] -> ()
+  | _ -> assert false
+
+let c = [1.; 2.]
+let () =
+  match Sys.opaque_identity c with
+  | [1.; 2.] -> ()
+  | _ -> assert false
+
+let () =
+  match c with
+  | [1.; 2.] -> ()
+  | _ -> assert false
+
+let d = [|1.; 2.|]
+let () =
+  match Sys.opaque_identity d with
+  | [|1.; 2.|] -> ()
+  | _ -> assert false
+
+let () =
+  match d with
+  | [|1.; 2.|] -> ()
+  | _ -> assert false
+
+let long_array =
+  [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12;
+    13; 14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 25;
+    26; 27; 28; 29; 30; 31; 32; 33; 34; 35; 36; 37; 38;
+    39; 40; 41; 42; 43; 44; 45; 46; 47; 48; 49; 50; 51;
+    52; 53; 54; 55; 56; 57; 58; 59; 60; 61; 62; 63; 64;
+    65; 66; 67; 68; 69; 70; 71; 72; 73; 74; 75; 76; 77;
+    78; 79; 80; 81; 82; 83; 84; 85; 86; 87; 88; 89; 90;
+    91; 92; 93; 94; 95; 96; 97; 98; 99; 100; 101; 102; 103;
+    104; 105; 106; 107; 108; 109; 110; 111; 112; 113; 114; 115; 116;
+    117; 118; 119; 120; 121; 122; 123; 124; 125; 126; 127; 128; 129;
+    130; 131; 132; 133; 134; 135; 136; 137; 138; 139; 140; 141; 142;
+    143; 144; 145; 146; 147; 148; 149; 150; 151; 152; 153; 154; 155;
+    156; 157; 158; 159; 160; 161; 162; 163; 164; 165; 166; 167; 168;
+    169; 170; 171; 172; 173; 174; 175; 176; 177; 178; 179; 180; 181;
+    182; 183; 184; 185; 186; 187; 188; 189; 190; 191; 192; 193; 194;
+    195; 196; 197; 198; 199; 200; 201; 202; 203; 204; 205; 206; 207;
+    208; 209; 210; 211; 212; 213; 214; 215; 216; 217; 218; 219; 220;
+    221; 222; 223; 224; 225; 226; 227; 228; 229; 230; 231; 232; 233;
+    234; 235; 236; 237; 238; 239; 240; 241; 242; 243; 244; 245; 246;
+    247; 248; 249; 250; 251; 252; 253; 254; 255; 256; 257; 258; 259;
+    260; 261; 262; 263; 264; 265; 266; 267; 268; 269; 270; 271; 272;
+    273; 274; 275; 276; 277; 278; 279; 280; 281; 282; 283; 284; 285;
+    286; 287; 288; 289; 290; 291; 292; 293; 294; 295; 296; 297; 298;
+    299; 300; 301; 302; 303; 304; 305; 306; 307; 308; 309; 310; 311;
+    312; 313; 314; 315; 316; 317; 318; 319; 320; 321; 322; 323; 324;
+    325; 326; 327; 328; 329; 330; 331; 332; 333; 334; 335; 336; 337;
+    338; 339; 340; 341; 342; 343; 344; 345; 346; 347; 348; 349; 350;
+    351; 352; 353; 354; 355; 356; 357; 358; 359; 360; 361; 362; 363;
+    364; 365; 366; 367; 368; 369; 370; 371; 372; 373; 374; 375; 376;
+    377; 378; 379; 380; 381; 382; 383; 384; 385; 386; 387; 388; 389;
+    390; 391; 392; 393; 394; 395; 396; 397; 398; 399; 400; 401; 402;
+    403; 404; 405; 406; 407; 408; 409; 410; 411; 412; 413; 414; 415;
+    416; 417; 418; 419; 420; 421; 422; 423; 424; 425; 426; 427; 428;
+    429; 430; 431; 432; 433; 434; 435; 436; 437; 438; 439; 440; 441;
+    442; 443; 444; 445; 446; 447; 448; 449; 450; 451; 452; 453; 454;
+    455; 456; 457; 458; 459; 460; 461; 462; 463; 464; 465; 466; 467;
+    468; 469; 470; 471; 472; 473; 474; 475; 476; 477; 478; 479; 480;
+    481; 482; 483; 484; 485; 486; 487; 488; 489; 490; 491; 492; 493;
+    494; 495; 496; 497; 498; 499; 500; 501; 502; 503; 504; 505; 506;
+    507; 508; 509; 510; 511; 512; 513; 514; 515; 516; 517; 518; 519;
+    520; 521; 522; 523; 524; 525; 526; 527; 528; 529; 530; 531; 532;
+    533; 534; 535; 536; 537; 538; 539; 540; 541; 542; 543; 544; 545;
+    546; 547; 548; 549; 550; 551; 552; 553; 554; 555; 556; 557; 558;
+    559; 560; 561; 562; 563; 564; 565; 566; 567; 568; 569; 570; 571;
+    572; 573; 574; 575; 576; 577; 578; 579; 580; 581; 582; 583; 584;
+    585; 586; 587; 588; 589; 590; 591; 592; 593; 594; 595; 596; 597;
+    598; 599; 600; 601; 602; 603; 604; 605; 606; 607; 608; 609; 610;
+    611; 612; 613; 614; 615; 616; 617; 618; 619; 620; 621; 622; 623;
+    624; 625; 626; 627; 628; 629; 630; 631; 632; 633; 634; 635; 636;
+    637; 638; 639; 640; 641; 642; 643; 644; 645; 646; 647; 648; 649;
+    650; 651; 652; 653; 654; 655; 656; 657; 658; 659; 660; 661; 662;
+    663; 664; 665; 666; 667; 668; 669; 670; 671; 672; 673; 674; 675;
+    676; 677; 678; 679; 680; 681; 682; 683; 684; 685; 686; 687; 688;
+    689; 690; 691; 692; 693; 694; 695; 696; 697; 698; 699; 700; 701;
+    702; 703; 704; 705; 706; 707; 708; 709; 710; 711; 712; 713; 714;
+    715; 716; 717; 718; 719; 720; 721; 722; 723; 724; 725; 726; 727;
+    728; 729; 730; 731; 732; 733; 734; 735; 736; 737; 738; 739; 740;
+    741; 742; 743; 744; 745; 746; 747; 748; 749; 750; 751; 752; 753;
+    754; 755; 756; 757; 758; 759; 760; 761; 762; 763; 764; 765; 766;
+    767; 768; 769; 770; 771; 772; 773; 774; 775; 776; 777; 778; 779;
+    780; 781; 782; 783; 784; 785; 786; 787; 788; 789; 790; 791; 792;
+    793; 794; 795; 796; 797; 798; 799; 800; 801; 802; 803; 804; 805;
+    806; 807; 808; 809; 810; 811; 812; 813; 814; 815; 816; 817; 818;
+    819; 820; 821; 822; 823; 824; 825; 826; 827; 828; 829; 830; 831;
+    832; 833; 834; 835; 836; 837; 838; 839; 840; 841; 842; 843; 844;
+    845; 846; 847; 848; 849; 850; 851; 852; 853; 854; 855; 856; 857;
+    858; 859; 860; 861; 862; 863; 864; 865; 866; 867; 868; 869; 870;
+    871; 872; 873; 874; 875; 876; 877; 878; 879; 880; 881; 882; 883;
+    884; 885; 886; 887; 888; 889; 890; 891; 892; 893; 894; 895; 896;
+    897; 898; 899; 900; 901; 902; 903; 904; 905; 906; 907; 908; 909;
+    910; 911; 912; 913; 914; 915; 916; 917; 918; 919; 920; 921; 922;
+    923; 924; 925; 926; 927; 928; 929; 930; 931; 932; 933; 934; 935;
+    936; 937; 938; 939; 940; 941; 942; 943; 944; 945; 946; 947; 948;
+    949; 950; 951; 952; 953; 954; 955; 956; 957; 958; 959; 960; 961;
+    962; 963; 964; 965; 966; 967; 968; 969; 970; 971; 972; 973; 974;
+    975; 976; 977; 978; 979; 980; 981; 982; 983; 984; 985; 986; 987;
+    988; 989; 990; 991; 992; 993; 994; 995; 996; 997; 998; 999; 1000;
+    1001; 1002; 1003; 1004; 1005; 1006; 1007; 1008; 1009; 1010; 1011; 1012; 1013;
+    1014; 1015; 1016; 1017; 1018; 1019; 1020; 1021; 1022; 1023; 1024; 1025; 1026;
+    1027; 1028; 1029; 1030; 1031; 1032; 1033; 1034; 1035; 1036; 1037; 1038; 1039;
+    1040; 1041; 1042; 1043; 1044; 1045; 1046; 1047; 1048; 1049; 1050; 1051; 1052;
+    1053; 1054; 1055; 1056; 1057; 1058; 1059; 1060; 1061; 1062; 1063; 1064; 1065;
+    1066; 1067; 1068; 1069; 1070; 1071; 1072; 1073; 1074; 1075; 1076; 1077; 1078;
+    1079; 1080; 1081; 1082; 1083; 1084; 1085; 1086; 1087; 1088; 1089; 1090; 1091;
+    1092; 1093; 1094; 1095; 1096; 1097; 1098; 1099; 1100; 1101; 1102; 1103; 1104;
+    1105; 1106; 1107; 1108; 1109; 1110; 1111; 1112; 1113; 1114; 1115; 1116; 1117;
+    1118; 1119; 1120; 1121; 1122; 1123; 1124; 1125; 1126; 1127; 1128; 1129; 1130;
+    1131; 1132; 1133; 1134; 1135; 1136; 1137; 1138; 1139; 1140; 1141; 1142; 1143;
+    1144; 1145; 1146; 1147; 1148; 1149; 1150; 1151; 1152; 1153; 1154; 1155; 1156;
+    1157; 1158; 1159; 1160; 1161; 1162; 1163; 1164; 1165; 1166; 1167; 1168; 1169;
+    1170; 1171; 1172; 1173; 1174; 1175; 1176; 1177; 1178; 1179; 1180; 1181; 1182;
+    1183; 1184; 1185; 1186; 1187; 1188; 1189; 1190; 1191; 1192; 1193; 1194; 1195;
+    1196; 1197; 1198; 1199; 1200; 1201; 1202; 1203; 1204; 1205; 1206; 1207; 1208;
+    1209; 1210; 1211; 1212; 1213; 1214; 1215; 1216; 1217; 1218; 1219; 1220; 1221;
+    1222; 1223; 1224; 1225; 1226; 1227; 1228; 1229; 1230; 1231; 1232; 1233; 1234;
+    1235; 1236; 1237; 1238; 1239; 1240; 1241; 1242; 1243; 1244; 1245; 1246; 1247;
+    1248; 1249; 1250; 1251; 1252; 1253; 1254; 1255; 1256; 1257; 1258; 1259; 1260;
+    1261; 1262; 1263; 1264; 1265; 1266; 1267; 1268; 1269; 1270; 1271; 1272; 1273;
+    1274; 1275; 1276; 1277; 1278; 1279; 1280; 1281; 1282; 1283; 1284; 1285; 1286;
+    1287; 1288; 1289; 1290; 1291; 1292; 1293; 1294; 1295; 1296; 1297; 1298; 1299;
+    1300; 1301; 1302; 1303; 1304; 1305; 1306; 1307; 1308; 1309; 1310; 1311; 1312;
+    1313; 1314; 1315; 1316; 1317; 1318; 1319; 1320; 1321; 1322; 1323; 1324; 1325;
+    1326; 1327; 1328; 1329; 1330; 1331; 1332; 1333; 1334; 1335; 1336; 1337; 1338;
+    1339; 1340; 1341; 1342; 1343; 1344; 1345; 1346; 1347; 1348; 1349; 1350; 1351;
+    1352; 1353; 1354; 1355; 1356; 1357; 1358; 1359; 1360; 1361; 1362; 1363; 1364;
+    1365; 1366; 1367; 1368; 1369; 1370; 1371; 1372; 1373; 1374; 1375; 1376; 1377;
+    1378; 1379; 1380; 1381; 1382; 1383; 1384; 1385; 1386; 1387; 1388; 1389; 1390;
+    1391; 1392; 1393; 1394; 1395; 1396; 1397; 1398; 1399; 1400; 1401; 1402; 1403;
+    1404; 1405; 1406; 1407; 1408; 1409; 1410; 1411; 1412; 1413; 1414; 1415; 1416;
+    1417; 1418; 1419; 1420; 1421; 1422; 1423; 1424; 1425; 1426; 1427; 1428; 1429;
+    1430; 1431; 1432; 1433; 1434; 1435; 1436; 1437; 1438; 1439; 1440; 1441; 1442;
+    1443; 1444; 1445; 1446; 1447; 1448; 1449; 1450; 1451; 1452; 1453; 1454; 1455;
+    1456; 1457; 1458; 1459; 1460; 1461; 1462; 1463; 1464; 1465; 1466; 1467; 1468;
+    1469; 1470; 1471; 1472; 1473; 1474; 1475; 1476; 1477; 1478; 1479; 1480; 1481;
+    1482; 1483; 1484; 1485; 1486; 1487; 1488; 1489; 1490; 1491; 1492; 1493; 1494;
+    1495; 1496; 1497; 1498; 1499; 1500; 1501; 1502; 1503; 1504; 1505; 1506; 1507;
+    1508; 1509; 1510; 1511; 1512; 1513; 1514; 1515; 1516; 1517; 1518; 1519; 1520;
+    1521; 1522; 1523; 1524; 1525; 1526; 1527; 1528; 1529; 1530; 1531; 1532; 1533;
+    1534; 1535; 1536; 1537; 1538; 1539; 1540; 1541; 1542; 1543; 1544; 1545; 1546;
+    1547; 1548; 1549; 1550; 1551; 1552; 1553; 1554; 1555; 1556; 1557; 1558; 1559;
+    1560; 1561; 1562; 1563; 1564; 1565; 1566; 1567; 1568; 1569; 1570; 1571; 1572;
+    1573; 1574; 1575; 1576; 1577; 1578; 1579; 1580; 1581; 1582; 1583; 1584; 1585;
+    1586; 1587; 1588; 1589; 1590; 1591; 1592; 1593; 1594; 1595; 1596; 1597; 1598;
+    1599; 1600; 1601; 1602; 1603; 1604; 1605; 1606; 1607; 1608; 1609; 1610; 1611;
+    1612; 1613; 1614; 1615; 1616; 1617; 1618; 1619; 1620; 1621; 1622; 1623; 1624;
+    1625; 1626; 1627; 1628; 1629; 1630; 1631; 1632; 1633; 1634; 1635; 1636; 1637;
+    1638; 1639; 1640; 1641; 1642; 1643; 1644; 1645; 1646; 1647; 1648; 1649; 1650;
+    1651; 1652; 1653; 1654; 1655; 1656; 1657; 1658; 1659; 1660; 1661; 1662; 1663;
+    1664; 1665; 1666; 1667; 1668; 1669; 1670; 1671; 1672; 1673; 1674; 1675; 1676;
+    1677; 1678; 1679; 1680; 1681; 1682; 1683; 1684; 1685; 1686; 1687; 1688; 1689;
+    1690; 1691; 1692; 1693; 1694; 1695; 1696; 1697; 1698; 1699; 1700; 1701; 1702;
+    1703; 1704; 1705; 1706; 1707; 1708; 1709; 1710; 1711; 1712; 1713; 1714; 1715;
+    1716; 1717; 1718; 1719; 1720; 1721; 1722; 1723; 1724; 1725; 1726; 1727; 1728;
+    1729; 1730; 1731; 1732; 1733; 1734; 1735; 1736; 1737; 1738; 1739; 1740; 1741;
+    1742; 1743; 1744; 1745; 1746; 1747; 1748; 1749; 1750; 1751; 1752; 1753; 1754;
+    1755; 1756; 1757; 1758; 1759; 1760; 1761; 1762; 1763; 1764; 1765; 1766; 1767;
+    1768; 1769; 1770; 1771; 1772; 1773; 1774; 1775; 1776; 1777; 1778; 1779; 1780;
+    1781; 1782; 1783; 1784; 1785; 1786; 1787; 1788; 1789; 1790; 1791; 1792; 1793;
+    1794; 1795; 1796; 1797; 1798; 1799; 1800; 1801; 1802; 1803; 1804; 1805; 1806;
+    1807; 1808; 1809; 1810; 1811; 1812; 1813; 1814; 1815; 1816; 1817; 1818; 1819;
+    1820; 1821; 1822; 1823; 1824; 1825; 1826; 1827; 1828; 1829; 1830; 1831; 1832;
+    1833; 1834; 1835; 1836; 1837; 1838; 1839; 1840; 1841; 1842; 1843; 1844; 1845;
+    1846; 1847; 1848; 1849; 1850; 1851; 1852; 1853; 1854; 1855; 1856; 1857; 1858;
+    1859; 1860; 1861; 1862; 1863; 1864; 1865; 1866; 1867; 1868; 1869; 1870; 1871;
+    1872; 1873; 1874; 1875; 1876; 1877; 1878; 1879; 1880; 1881; 1882; 1883; 1884;
+    1885; 1886; 1887; 1888; 1889; 1890; 1891; 1892; 1893; 1894; 1895; 1896; 1897;
+    1898; 1899; 1900; 1901; 1902; 1903; 1904; 1905; 1906; 1907; 1908; 1909; 1910;
+    1911; 1912; 1913; 1914; 1915; 1916; 1917; 1918; 1919; 1920; 1921; 1922; 1923;
+    1924; 1925; 1926; 1927; 1928; 1929; 1930; 1931; 1932; 1933; 1934; 1935; 1936;
+    1937; 1938; 1939; 1940; 1941; 1942; 1943; 1944; 1945; 1946; 1947; 1948; 1949;
+    1950; 1951; 1952; 1953; 1954; 1955; 1956; 1957; 1958; 1959; 1960; 1961; 1962;
+    1963; 1964; 1965; 1966; 1967; 1968; 1969; 1970; 1971; 1972; 1973; 1974; 1975;
+    1976; 1977; 1978; 1979; 1980; 1981; 1982; 1983; 1984; 1985; 1986; 1987; 1988;
+    1989; 1990; 1991; 1992; 1993; 1994; 1995; 1996; 1997; 1998; 1999; 2000; 2001;
+    2002; 2003; 2004; 2005; 2006; 2007; 2008; 2009; 2010; 2011; 2012; 2013; 2014;
+    2015; 2016; 2017; 2018; 2019; 2020; 2021; 2022; 2023; 2024; 2025; 2026; 2027;
+    2028; 2029; 2030; 2031; 2032; 2033; 2034; 2035; 2036; 2037; 2038; 2039; 2040;
+    2041; 2042; 2043; 2044; 2045; 2046; 2047; 2048; 2049; 2050; 2051; 2052; 2053;
+    2054; 2055; 2056; 2057; 2058; 2059; 2060; 2061; 2062; 2063; 2064; 2065; 2066;
+    2067; 2068; 2069; 2070; 2071; 2072; 2073; 2074; 2075; 2076; 2077; 2078; 2079;
+    2080; 2081; 2082; 2083; 2084; 2085; 2086; 2087; 2088; 2089; 2090; 2091; 2092;
+    2093; 2094; |]
+
+let () =
+  let long_array = Sys.opaque_identity long_array in
+  for i = 0 to Array.length long_array - 1 do
+    assert(long_array.(i) = i)
+  done

diff --git a/testsuite/tests/basic-more/structural_constants.reference b/testsuite/tests/basic-more/structural_constants.reference
new file mode 100644 (file)
index 0000000..197c928
--- /dev/null
+++ b/testsuite/tests/basic-more/structural_constants.reference
@@ -0,0 +1,2 @@
+
+All tests succeeded.

diff --git a/testsuite/tests/basic-more/tbuffer.ml b/testsuite/tests/basic-more/tbuffer.ml
index 75f49dd10fbc6e0170ca0ea1d197a099a56889bc..b8348575844a495db33639e2c66eeb7fe60095b0 100644 (file)
--- a/testsuite/tests/basic-more/tbuffer.ml
+++ b/testsuite/tests/basic-more/tbuffer.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
-(*                                                                       *)
-(*   Copyright 2009 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (* Dummy substitute function. *)
 
 open Testing;;

diff --git a/testsuite/tests/basic-more/testrandom.ml b/testsuite/tests/basic-more/testrandom.ml
index 4588bb815954f42442fc6ad599b475f8b7cd1446..8a7ab475cf646e09af412be73c61a277bbe02782 100644 (file)
--- a/testsuite/tests/basic-more/testrandom.ml
+++ b/testsuite/tests/basic-more/testrandom.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Random
 
 let _ =

diff --git a/testsuite/tests/basic-more/tformat.ml b/testsuite/tests/basic-more/tformat.ml
index 64176d88f82b0ffd4f410a6431c1690a960e1629..7a628ed6902c9d9f0d62b61819d5ac9340d8f804 100644 (file)
--- a/testsuite/tests/basic-more/tformat.ml
+++ b/testsuite/tests/basic-more/tformat.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
-(*                                                                       *)
-(*   Copyright 2009 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (*
 
 A testbed file for the module Format.

diff --git a/testsuite/tests/basic-more/tprintf.ml b/testsuite/tests/basic-more/tprintf.ml
index 035bfe117590a2aff0bedc1a82660f432313955f..13b54a9e8ab1d3e06008e77c5221eb08a9bd3164 100644 (file)
--- a/testsuite/tests/basic-more/tprintf.ml
+++ b/testsuite/tests/basic-more/tprintf.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Testing;;
 
 open Printf;;

diff --git a/testsuite/tests/basic-multdef/multdef.ml b/testsuite/tests/basic-multdef/multdef.ml
index f1935d8550071e4ddd35d7192c4c3078ae212ae5..46869c45602d46473cbe347e117e1c26914a9f28 100644 (file)
--- a/testsuite/tests/basic-multdef/multdef.ml
+++ b/testsuite/tests/basic-multdef/multdef.ml
@@ -1,17 +1,2 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f x = x + 1
 external g : string -> int = "caml_int_of_string"

diff --git a/testsuite/tests/basic-multdef/multdef.mli b/testsuite/tests/basic-multdef/multdef.mli
index d6f8c09043e86b5bf5c6cb0d4252f0480401735b..8d67a548f6b19af0bdf5b2a9b06892428f8eb70f 100644 (file)
--- a/testsuite/tests/basic-multdef/multdef.mli
+++ b/testsuite/tests/basic-multdef/multdef.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 val f : int -> int
 val f : int -> int
 val g : string -> int

diff --git a/testsuite/tests/basic-multdef/usemultdef.ml b/testsuite/tests/basic-multdef/usemultdef.ml
index 3ec7639c15382401a6871707f9729ee9fa3a37a9..2bccabb693e279ef6c7261f96112c523294d9b9d 100644 (file)
--- a/testsuite/tests/basic-multdef/usemultdef.ml
+++ b/testsuite/tests/basic-multdef/usemultdef.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let _ = print_int(Multdef.f 1); print_newline(); exit 0

diff --git a/testsuite/tests/basic-private/length.ml b/testsuite/tests/basic-private/length.ml
index 5db6c45db350a19ca191746fc677861bcd14e3b8..c36e6702733fd186e9b6fb0f01c010903ba029c0 100644 (file)
--- a/testsuite/tests/basic-private/length.ml
+++ b/testsuite/tests/basic-private/length.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*
 
 A testbed file for private type abbreviation definitions.

diff --git a/testsuite/tests/basic-private/length.mli b/testsuite/tests/basic-private/length.mli
index 6478f78298e3f5d535afb52def6035336f5402b6..67d055db68522be703e52ebb0c465785b88f44fa 100644 (file)
--- a/testsuite/tests/basic-private/length.mli
+++ b/testsuite/tests/basic-private/length.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*
 
 A testbed file for private type abbreviation definitions.

diff --git a/testsuite/tests/basic-private/tlength.ml b/testsuite/tests/basic-private/tlength.ml
index 812057bb916c9c8052a352ee11f5ed30c26a355a..73f0bf9548963c81410bc7ac3e3cc17758ca4045 100644 (file)
--- a/testsuite/tests/basic-private/tlength.ml
+++ b/testsuite/tests/basic-private/tlength.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*
 
 A testbed file for private type abbreviation definitions.

diff --git a/testsuite/tests/basic/Makefile b/testsuite/tests/basic/Makefile
index c11a415f745638e21ecfa11c3b99191c7549d854..446664a9d8d9b1dc0566cdb37f2a130fd3fa9234 100644 (file)
--- a/testsuite/tests/basic/Makefile
+++ b/testsuite/tests/basic/Makefile
@@ -13,6 +13,21 @@
 #*                                                                        *
 #**************************************************************************
 
+all: pr6322.ml check
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES=pr6322.ml *.safe-string
+
+pr6322.ml: $(SAFE_STRING).safe-string
+ifeq ($(SAFE_STRING),false)
+       @cat pr6322.ml.in > $@
+else
+       @echo "Printf.printf \"PR#6322=Ok\\n%!\"" > $@
+endif
+
+%.safe-string:
+       @rm -f pr6322.ml
+       @touch $@

diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml
index a873aa58912df955ce0bd0e0cb8fcf9df71c4b27..1ec4e4ebf50d4a82ca9c5b1641db492df9bde08a 100644 (file)
--- a/testsuite/tests/basic/arrays.ml
+++ b/testsuite/tests/basic/arrays.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let bigarray n = [|
 n+0; n+1; n+2; n+3; n+4; n+5; n+6; n+7; n+8; n+9; n+10; n+11; n+12;
 n+13; n+14; n+15; n+16; n+17; n+18; n+19; n+20; n+21; n+22; n+23;

diff --git a/testsuite/tests/basic/bigints.ml b/testsuite/tests/basic/bigints.ml
index 3fce1a876eefc75f7080ee82f958914ef14e8679..23e571c3fc2d24a8d84fb290339f6da6696a05dd 100644 (file)
--- a/testsuite/tests/basic/bigints.ml
+++ b/testsuite/tests/basic/bigints.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let _ =
   match Sys.word_size with
   | 32 ->

diff --git a/testsuite/tests/basic/boxedints.ml b/testsuite/tests/basic/boxedints.ml
index 00f936bb7021bd1256506bf96d7ad95dee259b78..016916f4d8f0e5ba6ee7ac3cc2d18168e6ca37c8 100644 (file)
--- a/testsuite/tests/basic/boxedints.ml
+++ b/testsuite/tests/basic/boxedints.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test the types nativeint, int32, int64 *)
 
 open Printf

diff --git a/testsuite/tests/basic/constprop.ml b/testsuite/tests/basic/constprop.ml
index 62bf5f25c723f10cd1ca0186814918c953dffe58..89d988831e52ce5fbd40c3c27e7c8171bb48e0fd 100644 (file)
--- a/testsuite/tests/basic/constprop.ml
+++ b/testsuite/tests/basic/constprop.ml
@@ -1,15 +1,3 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
-(*                                                                     *)
-(* Copyright 2014 Institut National de Recherche en Informatique et    *)
-(* en Automatique. All rights reserved. This file is distributed       *)
-(* under the terms of the Q Public License version 1.0.                *)
-(*                                                                     *)
-(***********************************************************************)
-
 (* Test constant propagation through inlining *)
 
 (* constprop.ml is generated from constprop.mlp using

diff --git a/testsuite/tests/basic/constprop.mlp b/testsuite/tests/basic/constprop.mlp
index 3f6809653567c6c517b0dbc9b74a56969c57dc1b..f08bc50fa61a98a8c5090f1956b9bf871cc03997 100644 (file)
--- a/testsuite/tests/basic/constprop.mlp
+++ b/testsuite/tests/basic/constprop.mlp
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test constant propagation through inlining *)
 
 (* constprop.ml is generated from constprop.mlp using

diff --git a/testsuite/tests/basic/divint.ml b/testsuite/tests/basic/divint.ml
index 8299f045f440c30303af02fe80e53b2399b2cae5..77c165bae83f13262e9ba7fb141e63b8a4d31a4d 100644 (file)
--- a/testsuite/tests/basic/divint.ml
+++ b/testsuite/tests/basic/divint.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Test integer division and modulus, esp. ocamlopt's optimization

diff --git a/testsuite/tests/basic/equality.ml b/testsuite/tests/basic/equality.ml
index 6e8d9a001f187e6c98efa415347b361982114c11..ebf5cf438bb3da16069f595008ccb6633e7c3c4f 100644 (file)
--- a/testsuite/tests/basic/equality.ml
+++ b/testsuite/tests/basic/equality.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let test n check res =
   print_string "Test "; print_int n;
   if check res then print_string " passed.\n" else print_string " FAILED.\n";

diff --git a/testsuite/tests/basic/float.ml b/testsuite/tests/basic/float.ml
index 0f1a93a4a16945e1e020e50d7db00c9477a2edf5..9ebabbc4b60bf9937acbd2aea606c23d4edce026 100644 (file)
--- a/testsuite/tests/basic/float.ml
+++ b/testsuite/tests/basic/float.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Moscova, INRIA Rocqencourt            *)
-(*                                                                        *)
-(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 Printf.printf "1./.0. = %f\n" (1.0 /. 0.0);;

diff --git a/testsuite/tests/basic/includestruct.ml b/testsuite/tests/basic/includestruct.ml
index bc0611c49e3ec7e844a7c1cc56fd55f30d93ff78..15708bf970521539fa83b7caab3fe9de1ae725ed 100644 (file)
--- a/testsuite/tests/basic/includestruct.ml
+++ b/testsuite/tests/basic/includestruct.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test for "include <module-expr>" inside structures *)
 
 module A =

diff --git a/testsuite/tests/basic/localexn.ml b/testsuite/tests/basic/localexn.ml
new file mode 100755 (executable)
index 0000000..b0f8e85
--- /dev/null
+++ b/testsuite/tests/basic/localexn.ml
@@ -0,0 +1,9 @@
+let f (type t) () =
+  let exception E of t in
+  (fun x -> E x), (function E _ -> print_endline "OK" | _ -> print_endline "KO")
+
+let inj1, proj1 = f ()
+let inj2, proj2 = f ()
+
+let () = proj1 (inj1 42)
+let () = proj1 (inj2 42)

diff --git a/testsuite/tests/basic/localexn.reference b/testsuite/tests/basic/localexn.reference
new file mode 100644 (file)
index 0000000..cd89967
--- /dev/null
+++ b/testsuite/tests/basic/localexn.reference
@@ -0,0 +1,2 @@
+OK
+KO

diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml
index 24b0e3370827c211b653e4fe639898ac993be49f..2ed02dec2083dd8c653e41711557aca00da7e9b2 100644 (file)
--- a/testsuite/tests/basic/maps.ml
+++ b/testsuite/tests/basic/maps.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module IntMap = Map.Make(struct type t = int let compare x y = x-y end)
 
 let m1 = IntMap.add 0 "A" (IntMap.add 4 "Y" (IntMap.singleton 3 "X1"))

diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml
index ce57ea506ab867f9a43bd169dde16e85cc55d0e6..43026be2057d1da12440ccc8eda341d3360825f3 100644 (file)
--- a/testsuite/tests/basic/patmatch.ml
+++ b/testsuite/tests/basic/patmatch.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Tests for matchings on integers and characters *)
 
 (* Dense integer switch *)
@@ -66,10 +51,12 @@ let l = function
 
 open Printf
 
-external string_create: int -> string = "caml_create_string"
+external bytes_create: int -> bytes = "caml_create_bytes"
 external unsafe_chr: int -> char = "%identity"
-external string_unsafe_set : string -> int -> char -> unit
-                           = "%string_unsafe_set"
+external bytes_unsafe_set : bytes -> int -> char -> unit
+                           = "%bytes_unsafe_set"
+
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
 
 (* The following function is roughly equivalent to Char.escaped,
    except that it is locale-independent. *)
@@ -82,17 +69,17 @@ let escaped = function
   | '\b' -> "\\b"
   | c ->
     if ((k c) <> "othr") && ((Char.code c) <= 191) then begin
-      let s = string_create 1 in
-      string_unsafe_set s 0 c;
-      s
+      let s = bytes_create 1 in
+      bytes_unsafe_set s 0 c;
+      unsafe_to_string s
     end else begin
       let n = Char.code c in
-      let s = string_create 4 in
-      string_unsafe_set s 0 '\\';
-      string_unsafe_set s 1 (unsafe_chr (48 + n / 100));
-      string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
-      string_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
-      s
+      let s = bytes_create 4 in
+      bytes_unsafe_set s 0 '\\';
+      bytes_unsafe_set s 1 (unsafe_chr (48 + n / 100));
+      bytes_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10));
+      bytes_unsafe_set s 3 (unsafe_chr (48 + n mod 10));
+      unsafe_to_string s
     end
 
 let _ =
@@ -159,18 +146,6 @@ let () =
   let r = test Foo false in
   if r = 0 then printf "PR#5788=Ok\n"
 
-
-(* No string sharing PR#6322 *)
-let test x = match x with
-  | true -> "a"
-  | false -> "a"
-
-let () =
-  let s1 = test true in
-  let s2 = test false in
-  s1.[0] <- 'p';
-  if s1 <> s2 then printf "PR#6322=Ok\n%!"
-
 (* PR#6646 Avoid explosion of default cases when there are many constructors *)
 
 (* This took forever to compile *)

diff --git a/testsuite/tests/basic/patmatch.reference b/testsuite/tests/basic/patmatch.reference
index 868bcf5353e1206c168c1fca42fd60158400f5ae..11cd189a9103faf464cd41226a3e1755414b061c 100644 (file)
--- a/testsuite/tests/basic/patmatch.reference
+++ b/testsuite/tests/basic/patmatch.reference
@@ -69,7 +69,6 @@ l([|4;5;6|]) = 15
 PR#5992=Ok
 PR#5788=Ok
 PR#5788=Ok
-PR#6322=Ok
 PR#6646=Ok
 PR#6646=Ok
 PR#6676=Ok

diff --git a/testsuite/tests/basic/pr6322.ml.in b/testsuite/tests/basic/pr6322.ml.in
new file mode 100644 (file)
index 0000000..460f0a3
--- /dev/null
+++ b/testsuite/tests/basic/pr6322.ml.in
@@ -0,0 +1,11 @@
+(* No string sharing PR#6322. This test is not applicable when OCaml is compiled with -safe-string. *)
+
+let test x = match x with
+  | true -> "a"
+  | false -> "a"
+
+let () =
+  let s1 = test true in
+  let s2 = test false in
+  s1.[0] <- 'p';
+  if s1 <> s2 then Printf.printf "PR#6322=Ok\n%!"

diff --git a/testsuite/tests/basic/pr6322.reference b/testsuite/tests/basic/pr6322.reference
new file mode 100644 (file)
index 0000000..e07c25c
--- /dev/null
+++ b/testsuite/tests/basic/pr6322.reference
@@ -0,0 +1 @@
+PR#6322=Ok

diff --git a/testsuite/tests/basic/recvalues.ml b/testsuite/tests/basic/recvalues.ml
index 1a5a7bec67f2a053e40edbdd05311d6faab300e9..df32f5e702d6bf7901f9431b01a53862a0eb4874 100644 (file)
--- a/testsuite/tests/basic/recvalues.ml
+++ b/testsuite/tests/basic/recvalues.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Recursive value definitions *)
 
 let _ =

diff --git a/testsuite/tests/basic/sets.ml b/testsuite/tests/basic/sets.ml
index 4fad1802f418c5e7bda1b27a39cd2e50f7b1ea3e..8ce6ad596bc61eeb8db27fc7bb51667d693a2049 100644 (file)
--- a/testsuite/tests/basic/sets.ml
+++ b/testsuite/tests/basic/sets.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module IntSet = Set.Make(struct type t = int let compare x y = x-y end)
 
 let even = List.fold_right IntSet.add [0; -2; 2; 4; 6; -10] IntSet.empty

diff --git a/testsuite/tests/basic/stringmatch.ml b/testsuite/tests/basic/stringmatch.ml
index be913cf43ec1f989706f4078e75965d0536bdfdd..e1f4bdb47123f4428a0a9ae8d2913896c8fb1cdd 100644 (file)
--- a/testsuite/tests/basic/stringmatch.ml
+++ b/testsuite/tests/basic/stringmatch.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Luc Maranget, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Empty string oddities *)
 
 let rec tst01 s = match s with

diff --git a/testsuite/tests/basic/tailcalls.ml b/testsuite/tests/basic/tailcalls.ml
index a86e490b8b1d9f4e52110cf932e36a699c8a3f83..9e998139c217001917f6978326ebae98ddf513a5 100644 (file)
--- a/testsuite/tests/basic/tailcalls.ml
+++ b/testsuite/tests/basic/tailcalls.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec tailcall4 a b c d =
   if a < 0
   then b

diff --git a/testsuite/tests/callback/tcallback.ml b/testsuite/tests/callback/tcallback.ml
index 9ff755ccec96494fe311099a7c4a30f0163a3236..121d3c570ed801226c641082659852b346462bb6 100644 (file)
--- a/testsuite/tests/callback/tcallback.ml
+++ b/testsuite/tests/callback/tcallback.ml
@@ -1,17 +1,4 @@
 (**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1995 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
 
 external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1"
 external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2"

diff --git a/testsuite/tests/docstrings/Makefile b/testsuite/tests/docstrings/Makefile
new file mode 100644 (file)
index 0000000..ec94f6c
--- /dev/null
+++ b/testsuite/tests/docstrings/Makefile
@@ -0,0 +1,4 @@
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.dparsetree
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/docstrings/empty.ml b/testsuite/tests/docstrings/empty.ml
new file mode 100644 (file)
index 0000000..a4394f6
--- /dev/null
+++ b/testsuite/tests/docstrings/empty.ml
@@ -0,0 +1,8 @@
+type t = Label (**)
+(** attached to t *)
+
+(**)
+
+(** Empty docstring comments should not generate attributes *)
+
+type w (**)

diff --git a/testsuite/tests/docstrings/empty.ml.reference b/testsuite/tests/docstrings/empty.ml.reference
new file mode 100644 (file)
index 0000000..5a91a65
--- /dev/null
+++ b/testsuite/tests/docstrings/empty.ml.reference
@@ -0,0 +1,52 @@
+[
+  structure_item (empty.ml[1,0+0]..[1,0+14])
+    Pstr_type Rec
+    [
+      type_declaration "t" (empty.ml[1,0+5]..[1,0+6]) (empty.ml[1,0+0]..[1,0+14])
+        attribute "ocaml.doc"
+          [
+            structure_item (empty.ml[2,20+0]..[2,20+20])
+              Pstr_eval
+              expression (empty.ml[2,20+0]..[2,20+20])
+                Pexp_constant PConst_string(" attached to t ",None)
+          ]
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_variant
+            [
+              (empty.ml[1,0+9]..[1,0+14])
+                "Label" (empty.ml[1,0+9]..[1,0+14])
+                []
+                None
+            ]
+        ptype_private = Public
+        ptype_manifest =
+          None
+    ]
+  structure_item (empty.ml[6,48+0]..[6,48+62])
+    Pstr_attribute "ocaml.text"
+    [
+      structure_item (empty.ml[6,48+0]..[6,48+62])
+        Pstr_eval
+        expression (empty.ml[6,48+0]..[6,48+62])
+          Pexp_constant PConst_string(" Empty docstring comments should not generate attributes ",None)
+    ]
+  structure_item (empty.ml[8,112+0]..[8,112+6])
+    Pstr_type Rec
+    [
+      type_declaration "w" (empty.ml[8,112+5]..[8,112+6]) (empty.ml[8,112+0]..[8,112+6])
+        ptype_params =
+          []
+        ptype_cstrs =
+          []
+        ptype_kind =
+          Ptype_abstract
+        ptype_private = Public
+        ptype_manifest =
+          None
+    ]
+]
+

diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml
index fbddd2b58f7c9dd249113594b6be8dabf4400eb1..ae21a1f29ca28a03a0ae1f7f327be2b406e026ff 100644 (file)
--- a/testsuite/tests/embedded/cmcaml.ml
+++ b/testsuite/tests/embedded/cmcaml.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* OCaml part of the code *)
 
 let rec fib n =

diff --git a/testsuite/tests/exotic-syntax/exotic.ml b/testsuite/tests/exotic-syntax/exotic.ml
index 719d4e6e81c1257c5be19af4e73e2775c34ad22b..51b968aa86b00f194cd362aea6243bb7a89ba343 100644 (file)
--- a/testsuite/tests/exotic-syntax/exotic.ml
+++ b/testsuite/tests/exotic-syntax/exotic.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Exotic OCaml syntax constructs found in the manual that are not *)
 (* used in the source of the OCaml distribution (even in the tests). *)
 

diff --git a/testsuite/tests/extension-constructor/test.ml b/testsuite/tests/extension-constructor/test.ml
index 7ffdb1c0d17cbe2c1209650e8d53d7bb3ec891df..d73777a35c6df85eb39ce7b852d8bba4c3368d02 100644 (file)
--- a/testsuite/tests/extension-constructor/test.ml
+++ b/testsuite/tests/extension-constructor/test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type t = ..
 
 module M = struct

diff --git a/testsuite/tests/float-unboxing/Makefile b/testsuite/tests/float-unboxing/Makefile
index d36ba939af027d0b41e68c2b12fe00e484c6ab0c..8f44b4fa3146391510961854191c72fa4446edbf 100644 (file)
--- a/testsuite/tests/float-unboxing/Makefile
+++ b/testsuite/tests/float-unboxing/Makefile
@@ -11,9 +11,22 @@
 #(***********************************************************************)
 
 BASEDIR=../..
-MODULES=
+MODULES=float_inline
 MAIN_MODULE=float_subst_boxed_number
 ADD_OPTCOMPFLAGS=-inline 20
 
 include $(BASEDIR)/makefiles/Makefile.one
 include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES=float_inline.ml *.flambda
+
+float_inline.ml: $(FLAMBDA).flambda
+ifeq ($(FLAMBDA),false)
+       @echo "let eliminate_intermediate_float_record () = ()" > $@
+else
+       @cat float_flambda.ml > $@
+endif
+
+%.flambda:
+       @rm -f float_inline.ml
+       @touch $@

diff --git a/testsuite/tests/float-unboxing/float_flambda.ml b/testsuite/tests/float-unboxing/float_flambda.ml
new file mode 100644 (file)
index 0000000..3c5dfde
--- /dev/null
+++ b/testsuite/tests/float-unboxing/float_flambda.ml
@@ -0,0 +1,9 @@
+let eliminate_intermediate_float_record () =
+  let r = ref 0. in
+  for n = 1 to 1000 do
+    let open Complex in
+    let c = { re = float n; im = 0. } in
+    r := !r +. (norm [@inlined]) ((add [@inlined]) c i);
+  done;
+  ignore (Sys.opaque_identity !r)
+

diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
index 58e5c3f3ce51cdd0519cbb677b352fb6b3654e7d..209b6a4fc41057c46d35105a565665451c334be1 100644 (file)
--- a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
+++ b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                    Mark Shinwell, Jane Street Europe                   *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module PR_6686 = struct
   type t =
    | A of float
@@ -52,7 +37,8 @@ let check_noalloc name f =
   match Filename.basename Sys.argv.(0) with
   | "program.byte" | "program.byte.exe" -> ()
   | "program.native" | "program.native.exe" ->
-    if alloc > 100. then failwith name
+      if alloc > 100. then
+        failwith (Printf.sprintf "%s; alloc = %.0f" name alloc)
   | _ -> assert false
 
 module GPR_109 = struct
@@ -75,7 +61,8 @@ let unbox_classify_float () =
   for i = 1 to 1000 do
     assert (classify_float !x = FP_normal);
     x := !x +. 1.
-  done
+  done;
+  ignore (Sys.opaque_identity !x)
 
 let unbox_compare_float () =
   let module M = struct type sf = { mutable x: float; y: float; } end in
@@ -83,9 +70,95 @@ let unbox_compare_float () =
   for i = 1 to 1000 do
     assert (compare x.M.x x.M.y >= 0);
     x.M.x <- x.M.x +. 1.
+  done;
+  ignore (Sys.opaque_identity x.M.x)
+
+let unbox_float_refs () =
+  let r = ref nan in
+  for i = 1 to 1000 do r := !r +. float i done;
+  ignore (Sys.opaque_identity !r)
+
+let unbox_let_float () =
+  let r = ref 0. in
+  for i = 1 to 1000 do
+    let y =
+      if i mod 2 = 0 then nan else float i
+    in
+    r := !r +. (y *. 2.)
+  done;
+  ignore (Sys.opaque_identity !r)
+
+type block =
+  { mutable float : float;
+    mutable int32 : int32 }
+
+let make_some_block record =
+  { record with int32 = record.int32 }
+
+let unbox_record_1 record =
+  (* There is some let lifting problem to handle that case with one
+     round, this currently requires 2 rounds to be correctly
+     recognized as a mutable variable pattern *)
+  (* let block = (make_some_block [@inlined]) record in *)
+  let block = { record with int32 = record.int32 } in
+  for i = 1 to 1000 do
+    let y_float =
+      if i mod 2 = 0 then nan else Pervasives.float i
+    in
+    block.float <- block.float +. (y_float *. 2.);
+    let y_int32 =
+      if i mod 2 = 0 then Int32.max_int else Int32.of_int i
+    in
+    block.int32 <- Int32.(add block.int32 (mul y_int32 2l))
+  done;
+  ignore (Sys.opaque_identity block.float);
+  ignore (Sys.opaque_identity block.int32)
+  [@@inline never]
+  (* Prevent inlining to test that the type is effectively used *)
+
+let float_int32_record = { float = 3.14; int32 = 12l }
+
+let unbox_record () =
+  unbox_record_1 float_int32_record
+
+let r = ref 0.
+
+let unbox_only_if_useful () =
+  for i = 1 to 1000 do
+    let x =
+      if i mod 2 = 0 then 1.
+      else 0.
+    in
+    r := x; (* would force boxing if the let binding above were unboxed *)
+    r := x  (* use [x] twice to avoid elimination of the let-binding *)
+  done;
+  ignore (Sys.opaque_identity !r)
+
+let unbox_minor_words () =
+  for i = 1 to 1000 do
+    ignore (Gc.minor_words () = 0.)
   done
 
 let () =
+  let flambda =
+    match Sys.getenv "FLAMBDA" with
+    | "true" -> true
+    | "false" -> false
+    | _ -> failwith "Cannot determine is flambda is enabled"
+    | exception Not_found -> failwith "Cannot determine is flambda is enabled"
+  in
+
   check_noalloc "classify float" unbox_classify_float;
   check_noalloc "compare float" unbox_compare_float;
+  check_noalloc "float refs" unbox_float_refs;
+  check_noalloc "unbox let float" unbox_let_float;
+  check_noalloc "unbox only if useful" unbox_only_if_useful;
+
+  if flambda then begin
+    check_noalloc "float and int32 record" unbox_record;
+    check_noalloc "eliminate intermediate immutable float record"
+      Float_inline.eliminate_intermediate_float_record;
+  end;
+
+  check_noalloc "Gc.minor_words" unbox_minor_words;
   ()

diff --git a/testsuite/tests/gc-roots/globroots.ml b/testsuite/tests/gc-roots/globroots.ml
index a12e24568febcfdb7996b47a7bb3e8f5be34e1ec..016277cf973ba7492b50577d657f796c58c048ef 100644 (file)
--- a/testsuite/tests/gc-roots/globroots.ml
+++ b/testsuite/tests/gc-roots/globroots.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module type GLOBREF = sig
   type t
   val register: string -> t
@@ -84,6 +69,9 @@ end
 module TestClassic = Test(Classic)
 module TestGenerational = Test(Generational)
 
+external young2old : unit -> unit = "gb_young2old"
+let _ = young2old (); Gc.full_major ()
+
 let _ =
   let n =
     if Array.length Sys.argv < 2 then 10000 else int_of_string Sys.argv.(1) in

diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c
index 5c540acf5555eef24d2ef8226a2d9274b0c9f080..28ad2267a299a684d021ce92c6a7250b42af7814 100644 (file)
--- a/testsuite/tests/gc-roots/globrootsprim.c
+++ b/testsuite/tests/gc-roots/globrootsprim.c
@@ -69,3 +69,15 @@ value gb_generational_remove(value vblock)
   caml_remove_generational_global_root(&(Block_val(vblock)->v));
   return Val_unit;
 }
+
+value root;
+
+value gb_young2old(value _dummy) {
+  root = caml_alloc_small(1, 0);
+  caml_register_generational_global_root(&root);
+  caml_modify_generational_global_root(&root, caml_alloc_shr(10, String_tag));
+  Field(root, 0) = 0xFFFFFFFF;
+  caml_remove_generational_global_root(&root);
+  root += sizeof(value);
+  return Val_unit;
+}

diff --git a/testsuite/tests/int64-unboxing/test.ml b/testsuite/tests/int64-unboxing/test.ml
index 40bed302fb47b41ab869e61577a097b811bf4518..4bffcc67c2e8f7e1c3a78487afe0f7123596cf8e 100644 (file)
--- a/testsuite/tests/int64-unboxing/test.ml
+++ b/testsuite/tests/int64-unboxing/test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external ( + ) : int64 -> int64 -> int64
   = "" "test_int64_add" [@@noalloc] [@@unboxed]
 external ( - ) : int64 -> int64 -> int64

diff --git a/testsuite/tests/lazy/Makefile b/testsuite/tests/lazy/Makefile
new file mode 100644 (file)
index 0000000..5961358
--- /dev/null
+++ b/testsuite/tests/lazy/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Mark Shinwell, Jane Street Europe                     *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group, LLC                                *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+ADD_OPTFLAGS=-O3
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lazy/lazy1.ml b/testsuite/tests/lazy/lazy1.ml
new file mode 100644 (file)
index 0000000..8ec74b6
--- /dev/null
+++ b/testsuite/tests/lazy/lazy1.ml
@@ -0,0 +1,14 @@
+(* Mantis 7301, due to A. Frisch *)
+
+let foo () =
+  (fun xs0 () -> Lazy.force (List.hd xs0) ())
+    (List.map (fun g -> lazy g)
+       [Lazy.force (  lazy ( let _ = () in fun () -> ()  ) )]
+    )
+
+let () =
+  let gen = foo () in
+  gen ();
+  Gc.compact ();
+  print_char 'A'; flush stdout;
+  gen ()

diff --git a/testsuite/tests/lazy/lazy1.reference b/testsuite/tests/lazy/lazy1.reference
new file mode 100644 (file)
index 0000000..8c7e5a6
--- /dev/null
+++ b/testsuite/tests/lazy/lazy1.reference
@@ -0,0 +1 @@
+A
\ No newline at end of file

diff --git a/testsuite/tests/letrec/backreferences.ml b/testsuite/tests/letrec/backreferences.ml
index 289f7bdb19686a584d920f39bb31acd145182e0e..4a893225b1b4882ec58ed762ec183a5b23af8fae 100644 (file)
--- a/testsuite/tests/letrec/backreferences.ml
+++ b/testsuite/tests/letrec/backreferences.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* testing backreferences; some compilation scheme may handle
    differently recursive references to a mutually-recursive RHS
    depending on whether it is before or after in the bindings list *)

diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml
index aed8fffe4de151f0902dbd6346559ac995905bf2..a7d0338802298bab6fbe1bed88cb76e6e634130a 100644 (file)
--- a/testsuite/tests/letrec/class_1.ml
+++ b/testsuite/tests/letrec/class_1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* class expression are compiled to recursive bindings *)
 class test =
 object

diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml
index 39d6988233bfa9290cdf05bbf18c8ce8109cf43c..71c7880d673095d9befe37bf0aad4cd80932e338 100644 (file)
--- a/testsuite/tests/letrec/class_2.ml
+++ b/testsuite/tests/letrec/class_2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* class expressions may also contain local recursive bindings *)
 class test =
   let rec f = print_endline "f"; fun x -> g x

diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml
index 87d5accb4a72277ba4cf8c6476d5bf1328e439ba..6c94439e17c8bf878909823a8e31f8c6fe95493c 100644 (file)
--- a/testsuite/tests/letrec/evaluation_order_1.ml
+++ b/testsuite/tests/letrec/evaluation_order_1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* test evaluation order
 
    'y' is translated into a constant, and is therefore considered
@@ -22,9 +7,9 @@
 type tree = Tree of tree list
 
 let test =
-  let rec x = (print_endline "x"; Tree [y; z])
-  and y = (print_endline "y"; Tree [])
-  and z = (print_endline "z"; Tree [x])
+  let rec x = (print_endline "effect"; Tree [y; z])
+  and y = (print_endline "effect"; Tree [])
+  and z = (print_endline "effect"; Tree [x])
   in
   match (x, y, z) with
     | (Tree [y1; z1], Tree[], Tree[x1]) ->

diff --git a/testsuite/tests/letrec/evaluation_order_1.reference b/testsuite/tests/letrec/evaluation_order_1.reference
index f471662b7d632d48aad51dfb171adbcbbc400bab..bf36c92541bdf64d4baf403d6206197dc8f60d54 100644 (file)
--- a/testsuite/tests/letrec/evaluation_order_1.reference
+++ b/testsuite/tests/letrec/evaluation_order_1.reference
@@ -1,3 +1,3 @@
-y
-x
-z
+effect
+effect
+effect

diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml
index 25b2c81cc4739c2e325ed7beb94408052e71b981..f8a845bd9a0cdba88b07747f67a511acf7fa11f7 100644 (file)
--- a/testsuite/tests/letrec/evaluation_order_2.ml
+++ b/testsuite/tests/letrec/evaluation_order_2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* A variant of evaluation_order_1.ml where the side-effects
    are inside the blocks.
    Effect are not named to allow different evaluation orders (flambda

diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml
index 64144a3f5db24b17aec074a7836ade08c8685f87..8f76a8f85824f56b430666fbf2baa81bf64685f3 100644 (file)
--- a/testsuite/tests/letrec/evaluation_order_3.ml
+++ b/testsuite/tests/letrec/evaluation_order_3.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type t = { x : t; y : t }
 
 let p = print_endline

diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml
index 21189e8fb507566a02415a004c746e8c942eca02..b2f878bba7345aee9e824912c88a99903819e1be 100644 (file)
--- a/testsuite/tests/letrec/float_block_1.ml
+++ b/testsuite/tests/letrec/float_block_1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Effect are not named to allow different evaluation orders (flambda
    and clambda differ on this point).
  *)

diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml
index e28011e1304bbe3138e197997aa9d4c51d44eee0..968cba4eb1e4fa095e037b46a7e69a924a55ad00 100644 (file)
--- a/testsuite/tests/letrec/float_block_2.ml
+++ b/testsuite/tests/letrec/float_block_2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* a bug in cmmgen.ml provokes a segfault in certain natively compiled
    letrec-bindings involving float arrays *)
 let test =

diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml
index e204e44907880f520f091859e0628f6926dafc23..5686e49357dc4c168e27555031d7d7b9e732d125 100644 (file)
--- a/testsuite/tests/letrec/lists.ml
+++ b/testsuite/tests/letrec/lists.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* a test with lists, because cyclic lists are fun *)
 let test =
   let rec li = 0::1::2::3::4::5::6::7::8::9::li in

diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml
index 8f5b112dbc0f13961ed31749da3283181503d2e0..e79f79ecbeeb63b91a75ebed6f83573bb6ba32df 100644 (file)
--- a/testsuite/tests/letrec/mixing_value_closures_1.ml
+++ b/testsuite/tests/letrec/mixing_value_closures_1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* mixing values and closures may exercise interesting code paths *)
 type t = A of (int -> int)
 let test =

diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml
index c8ab4fe01a2c1b17c5d3cae431c773b57af9b7a0..eb5fcb7420e92ed8dbd9ab5a5ca186e1c1aa09f2 100644 (file)
--- a/testsuite/tests/letrec/mixing_value_closures_2.ml
+++ b/testsuite/tests/letrec/mixing_value_closures_2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* a polymorphic variant of test3.ml; found a real bug once *)
 let test =
   let rec x = `A f

diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml
index 22f749f97d4c2ae8ae83d60b77186448a2cf7263..a5b6c51ffec363b1f9e0f341ce2bdcf6ede7c029 100644 (file)
--- a/testsuite/tests/letrec/mutual_functions.ml
+++ b/testsuite/tests/letrec/mutual_functions.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* a simple test with mutually recursive functions *)
 let test =
   let rec even = function

diff --git a/testsuite/tests/letrec/record_with.ml b/testsuite/tests/letrec/record_with.ml
index 7be7f5b806532b61fedde563bfb6aed6fbbd234d..8d2d01c0f3ebd5e787743c44ece072c7db2b40b0 100644 (file)
--- a/testsuite/tests/letrec/record_with.ml
+++ b/testsuite/tests/letrec/record_with.ml
@@ -1,19 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-
 (* A regression test for both PR#4141 and PR#5819: when a recursive
    variable is defined by a { record with ... } expression.
 *)

diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
index 942e2044520fd3160bb463d75c36a7781602afb6..d33862edd5136cac806426128e5eaa51f5880eb4 100644 (file)
--- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml
+++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Bigarray
 open Printf
 

diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml
index bdf3808e95f0630c4a005ae3348856d10d6a2016..9f8afc41883f34c7eeec338b53b15690ad1df8d9 100644 (file)
--- a/testsuite/tests/lib-bigarray/bigarrays.ml
+++ b/testsuite/tests/lib-bigarray/bigarrays.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Bigarray
 open Printf
 open Complex
@@ -42,7 +27,11 @@ let test test_number answer correct_answer =
 
 (* One-dimensional arrays *)
 
-let _ =
+(* flambda can cause some of these values not to be reclaimed by the Gc, which
+ * can undermine the use of Gc.full_major for the Windows ports. All the tests
+ * are wrapped in a non-inlineable function to prevent this behaviour.
+ *)
+let tests () =
   testing_function "------ Array1 --------";
   testing_function "create/set/get";
   let test_setget kind vals =
@@ -921,10 +910,12 @@ let _ =
   Sys.remove mapped_file;
 
   ()
+  [@@inline never]
 
 (********* End of test *********)
 
 let _ =
+  tests ();
   print_newline();
   if !error_occurred then begin
     prerr_endline "************* TEST FAILED ****************"; exit 2

diff --git a/testsuite/tests/lib-bigarray/fftba.ml b/testsuite/tests/lib-bigarray/fftba.ml
index 685d281d415f21f4752ce434133afa0ebcecb047..8a01389ccb8b2c1a11c1a5a0b8128abb8e2bc911 100644 (file)
--- a/testsuite/tests/lib-bigarray/fftba.ml
+++ b/testsuite/tests/lib-bigarray/fftba.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Bigarray
 
 let pi = 3.14159265358979323846

diff --git a/testsuite/tests/lib-bigarray/pr5115.ml b/testsuite/tests/lib-bigarray/pr5115.ml
index 2828d0842a4a484e1064f01f146ee8947d55aede..e75215cf75c26a3f8ba88d9452edd8e693067755 100644 (file)
--- a/testsuite/tests/lib-bigarray/pr5115.ml
+++ b/testsuite/tests/lib-bigarray/pr5115.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* PR#5115 - multiple evaluation of bigarray expr *)
 
 open Bigarray

diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml
index 6174ede25b3d5f64b1dd5fb3b8450c9e78939783..1b61d15262bcc2334da166bb5888a8077c159d9d 100644 (file)
--- a/testsuite/tests/lib-digest/md5.ml
+++ b/testsuite/tests/lib-digest/md5.ml
@@ -1,24 +1,9 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2003 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test int32 arithmetic and optimizations using the MD5 algorithm *)
 
 open Printf
 
 type context =
-  { buf: string;
+  { buf: bytes;
     mutable pos: int;
     mutable a: int32;
     mutable b: int32;
@@ -135,10 +120,10 @@ let string_to_data s =
   for i = 0 to 15 do
     let j = i lsl 2 in
     data.(i) <-
-      Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+3])) 24)
-        (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+2])) 16)
-          (Int32.logor (Int32.shift_left (Int32.of_int (Char.code s.[j+1])) 8)
-                       (Int32.of_int (Char.code s.[j]))))
+      Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+3) |> Char.code)) 24)
+        (Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+2) |> Char.code)) 16)
+          (Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+1) |> Char.code)) 8)
+                       (Int32.of_int (Bytes.get s j |> Char.code))))
   done;
   data
 
@@ -149,7 +134,7 @@ let int32_to_string n s i =
   s.[i] <- Char.chr (Int32.to_int n land 0xFF)
 
 let init () =
-  { buf = String.create 64;
+  { buf = Bytes.create 64;
     pos = 0;
     a = 0x67452301l;
     b = 0xefcdab89l;
@@ -162,12 +147,12 @@ let update ctx input ofs len =
     if len <= 0 then () else
     if ctx.pos + len < 64 then begin
       (* Just buffer the data *)
-      String.blit input ofs ctx.buf ctx.pos len;
+      Bytes.blit_string input ofs ctx.buf ctx.pos len;
       ctx.pos <- ctx.pos + len
     end else begin
       (* Fill the buffer *)
       let len' = 64 - ctx.pos in
-      if len' > 0 then String.blit input ofs ctx.buf ctx.pos len';
+      if len' > 0 then Bytes.blit_string input ofs ctx.buf ctx.pos len';
       (* Transform 64 bytes *)
       transform ctx (string_to_data ctx.buf);
       ctx.pos <- 0;
@@ -178,8 +163,7 @@ let update ctx input ofs len =
 
 
 let finish ctx =
-  let padding = String.make 64 '\000' in
-  padding.[0] <- '\x80';
+  let padding = String.init 64 (function 0 -> '\x80' | _ -> '\000') in
   let numbits = ctx.bits in
   if ctx.pos < 56 then begin
     update ctx padding 0 (56 - ctx.pos)
@@ -191,12 +175,12 @@ let finish ctx =
   data.(14) <- (Int64.to_int32 numbits);
   data.(15) <- (Int64.to_int32 (Int64.shift_right_logical numbits 32));
   transform ctx data;
-  let res = String.create 16 in
+  let res = Bytes.create 16 in
   int32_to_string ctx.a res 0;
   int32_to_string ctx.b res 4;
   int32_to_string ctx.c res 8;
   int32_to_string ctx.d res 12;
-  res
+  Bytes.unsafe_to_string res
 
 let test hex s =
   let ctx = init() in

diff --git a/testsuite/tests/lib-dynlink-bytecode/main.ml b/testsuite/tests/lib-dynlink-bytecode/main.ml
index ec35b2cccf20749e5466a3baf318cd7dea86d5cd..725ee80c9d7ccdb2372a77eeb1a29bdcd32ce901 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/main.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f x = print_string "This is Main.f\n"; x
 
 let () = Registry.register f

diff --git a/testsuite/tests/lib-dynlink-bytecode/plug1.ml b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
index be6d43e10ff8f648f478495ea94f50b70ef0248c..d0490689fbe116e2732a2571182ea5a95c795ed3 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/plug1.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external stub1: unit -> string = "stub1"
 
 let f x = print_string "This is Plug1.f\n"; x + 1

diff --git a/testsuite/tests/lib-dynlink-bytecode/plug2.ml b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
index b8816e94c600ebdd8d0e87d5ec33aa7d2c971a5d..350374e5b8b83c6a6bdf420ba90aca52831c9ba2 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/plug2.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external stub2: unit -> unit = "stub2"
 
 let f x = print_string "This is Plug2.f\n"; x + 2

diff --git a/testsuite/tests/lib-dynlink-bytecode/registry.ml b/testsuite/tests/lib-dynlink-bytecode/registry.ml
index 5006bc31bb3dcba3f54d80c5511427a74af6ae65..e0f76423dd94aed3dc89ae67f0674c0c6425483b 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/registry.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/registry.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let functions = ref ([]: (int -> int) list)
 
 let register f =

diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile
index 8bd618e6351bc22783a6441338961b12a05445dc..e3acc6b7a8e774e9e02b62bdd42ecf10f5196735 100644 (file)
--- a/testsuite/tests/lib-dynlink-csharp/Makefile
+++ b/testsuite/tests/lib-dynlink-csharp/Makefile
@@ -14,7 +14,8 @@
 #**************************************************************************
 
 BASEDIR=../..
-CSC=csc
+CSC_COMMAND=csc
+CSC=$(CSC_COMMAND) $(CSC_FLAGS)
 
 COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray -I $(OTOPDIR)/otherlibs/dynlink \
           -I $(OTOPDIR)/byterun
@@ -36,10 +37,11 @@ prepare:
 .PHONY: bytecode
 bytecode:
        @printf " ... testing 'bytecode':"
-       @if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC) >/dev/null 2>&1; \
+       @if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC_COMMAND) >/dev/null 2>&1; \
        then \
          echo " => skipped"; \
        else \
+         rm -f main.exe main.dll; \
          $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \
          $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
          ./main.exe > bytecode.result; \
@@ -50,10 +52,11 @@ bytecode:
 .PHONY: bytecode-dll
 bytecode-dll:
        @printf " ... testing 'bytecode-dll':"
-       @if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC) > /dev/null 2>&1; \
+       @if ! $(SUPPORTS_SHARED_LIBRARIES) || ! which $(CSC_COMMAND) > /dev/null 2>&1; \
        then \
          echo " => skipped"; \
        else \
+         rm -f main.exe main_obj.$(O) main.dll; \
          $(OCAMLC) -output-obj -o main_obj.$(O) dynlink.cma entry.c main.ml; \
          $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
                   $(CTOPDIR)/byterun/libcamlrun.$(A)  $(BYTECCLIBS); \
@@ -67,9 +70,10 @@ bytecode-dll:
 native:
        @printf " ... testing 'native':"
        @if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) \
-           || ! which $(CSC) > /dev/null 2>&1; then \
+           || ! which $(CSC_COMMAND) > /dev/null 2>&1; then \
          echo " => skipped"; \
        else \
+         rm -f main.exe main.dll; \
          $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \
          $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
          ./main.exe > native.result; \
@@ -81,13 +85,14 @@ native:
 native-dll:
        @printf " ... testing 'native-dll':"
        @if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) \
-           || ! which $(CSC) > /dev/null 2>&1; then \
+           || ! which $(CSC_COMMAND) > /dev/null 2>&1; then \
          echo " => skipped"; \
        else \
+         rm -f main.exe main_obj.$(O) main.dll; \
          $(OCAMLOPT) -output-obj -o main_obj.$(O) dynlink.cmxa entry.c \
                      main.ml; \
          $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) \
-                  $(CTOPDIR)/asmrun/libasmrun.lib -v; \
+                        $(CTOPDIR)/asmrun/libasmrun.lib $(NATIVECCLIBS); \
          $(CSC) /nologo /nowarn:1668 /out:main.exe main.cs; \
          ./main.exe > native-dll.result; \
          $(DIFF) native.reference native-dll.result >/dev/null \
@@ -102,3 +107,13 @@ clean: defaultclean
        @rm -f *.result *.exe *.dll *.so *.obj *.o
 
 include $(BASEDIR)/makefiles/Makefile.common
+
+ifneq ($(FLEXLINK_PREFIX),)
+MKDLL=$(WINTOPDIR)/boot/ocamlrun $(WINTOPDIR)/flexdll/flexlink.exe $(FLEXLINK_FLAGS)
+endif
+
+ifeq ($(HOST),msvc)
+CSC_FLAGS=/platform:x86
+else
+CSC_FLAGS=
+endif

diff --git a/testsuite/tests/lib-dynlink-csharp/main.ml b/testsuite/tests/lib-dynlink-csharp/main.ml
index e954e137c4119651248fe202c67606a15c50e5eb..d30c150e1d8c15890fa44cce9b5c1374d0c7587f 100755 (executable)
--- a/testsuite/tests/lib-dynlink-csharp/main.ml
+++ b/testsuite/tests/lib-dynlink-csharp/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let load s =
   Printf.printf "Loading %s\n%!" s;
   try

diff --git a/testsuite/tests/lib-dynlink-csharp/plugin.ml b/testsuite/tests/lib-dynlink-csharp/plugin.ml
index ede32744c99b9c0bb8c51ab4011c190d8d5f9b53..aacf9f21bcf29d08effb18cbefa225bb06f0e5d7 100755 (executable)
--- a/testsuite/tests/lib-dynlink-csharp/plugin.ml
+++ b/testsuite/tests/lib-dynlink-csharp/plugin.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f x = x.{2}
 
 let () =

diff --git a/testsuite/tests/lib-dynlink-native/a.ml b/testsuite/tests/lib-dynlink-native/a.ml
index 7b8ac49afb8f84c6658dc8ba12a7d64c42f21358..b79158225f57a6f121b02bd9f431873aa6ae6a73 100755 (executable)
--- a/testsuite/tests/lib-dynlink-native/a.ml
+++ b/testsuite/tests/lib-dynlink-native/a.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let x = ref 0
 let u = Random.int 1000
 

diff --git a/testsuite/tests/lib-dynlink-native/api.ml b/testsuite/tests/lib-dynlink-native/api.ml
index 4daa7d44a5b5e0d16d19a4fe27b13c9ec23f33a0..cd735abe3acbcc44cad553cebeb1672ca306fc84 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/api.ml
+++ b/testsuite/tests/lib-dynlink-native/api.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let mods = ref []
 
 let reg_mod name =

diff --git a/testsuite/tests/lib-dynlink-native/b.ml b/testsuite/tests/lib-dynlink-native/b.ml
index 95c142ba458c40cfd7347439449571def227b09c..afa1bef05186b5be93bcd92b26375ebf5afcd6d4 100755 (executable)
--- a/testsuite/tests/lib-dynlink-native/b.ml
+++ b/testsuite/tests/lib-dynlink-native/b.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   print_endline "B is running";
   incr A.x;

diff --git a/testsuite/tests/lib-dynlink-native/bug.ml b/testsuite/tests/lib-dynlink-native/bug.ml
index 7c3387f98816f38cb6809654a62e55ef3a279dab..31c0f02595a210c1c7515654a9af12378f77ff99 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/bug.ml
+++ b/testsuite/tests/lib-dynlink-native/bug.ml
@@ -1,17 +1,2 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () = try raise (Invalid_argument "X") with Invalid_argument s ->
   raise (Invalid_argument (s ^ s))

diff --git a/testsuite/tests/lib-dynlink-native/c.ml b/testsuite/tests/lib-dynlink-native/c.ml
index c7e799a385ddb86946281544c8ee2976082f7d71..d4de70f40af16f3d28795e6954a093b15eefd3e1 100755 (executable)
--- a/testsuite/tests/lib-dynlink-native/c.ml
+++ b/testsuite/tests/lib-dynlink-native/c.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   print_endline "C is running";
   incr A.x;

diff --git a/testsuite/tests/lib-dynlink-native/main.ml b/testsuite/tests/lib-dynlink-native/main.ml
index 20c0b9bff9f05852115caaabdecafab64c25307c..8c738aeb70cb23d25f97827f609f7a3e3142d476 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/main.ml
+++ b/testsuite/tests/lib-dynlink-native/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Api.add_cb (fun () -> print_endline "Callback from main")
 

diff --git a/testsuite/tests/lib-dynlink-native/pack_client.ml b/testsuite/tests/lib-dynlink-native/pack_client.ml
index 0766566f8a9f9e1b892ec01f35a7cd6ebfc03c71..90229885e0883449d413e9a1ea047f5c685bbe59 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/pack_client.ml
+++ b/testsuite/tests/lib-dynlink-native/pack_client.ml
@@ -1,17 +1,2 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   print_endline Mypack.Packed1.mykey

diff --git a/testsuite/tests/lib-dynlink-native/packed1.ml b/testsuite/tests/lib-dynlink-native/packed1.ml
index 8d13cbcede23f2158b4fdf8317c19022d83044ba..2ee8363391e764ceee59aa8f8033bd5240721e4d 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/packed1.ml
+++ b/testsuite/tests/lib-dynlink-native/packed1.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Api.reg_mod "Packed1"
 

diff --git a/testsuite/tests/lib-dynlink-native/packed1_client.ml b/testsuite/tests/lib-dynlink-native/packed1_client.ml
index 79416076d5c41506ee55993ff7352a79fc240dc6..c62534fdab6fbda2f668a03612ef06ab5d90ce95 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/packed1_client.ml
+++ b/testsuite/tests/lib-dynlink-native/packed1_client.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Api.reg_mod "Packed1_client";
   print_endline Packed1.mykey

diff --git a/testsuite/tests/lib-dynlink-native/plugin.ml b/testsuite/tests/lib-dynlink-native/plugin.ml
index 14806348fc4e6e82f8d59ba779fbecb0ebd7e83d..d9b0574f1bdb8053ff4b24498ee13ed83909ec45 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec f x = ignore ([x]); f x
 
 let rec fact n = if n = 0 then 1 else n * fact (n - 1)

diff --git a/testsuite/tests/lib-dynlink-native/plugin.mli b/testsuite/tests/lib-dynlink-native/plugin.mli
index 8e39ea09b94f5044fa103c92e44f53d1a4bc480d..3e659d97bcfdb64f5aa3481bcc88819bd17691a8 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin.mli
+++ b/testsuite/tests/lib-dynlink-native/plugin.mli
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 val facts: int list

diff --git a/testsuite/tests/lib-dynlink-native/plugin2.ml b/testsuite/tests/lib-dynlink-native/plugin2.ml
index f208d4e8493e4d25b14190bb537ca5344fdc790e..109c129d1a89f65f5d43adb04e8061d0c1560374 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin2.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*external ex: int -> int = "caml_ex"*)
 
 let () =

diff --git a/testsuite/tests/lib-dynlink-native/plugin4.ml b/testsuite/tests/lib-dynlink-native/plugin4.ml
index c64c4a5e871e47b79c366d2328a29b6ae977561d..a9f86e60a220a09b232a16e0856a355c93230d35 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin4.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin4.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Printf.printf "time = %f\n" (Unix.time ());
   Api.reg_mod "Plugin"

diff --git a/testsuite/tests/lib-dynlink-native/plugin_ext.ml b/testsuite/tests/lib-dynlink-native/plugin_ext.ml
index ffefb7191f45181d67d9323e7c0e2425b4ecb12a..9906769fe4e884f7158e414b831993d78ee0ab65 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin_ext.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_ext.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external fact: int -> string = "factorial"
 
 let () =

diff --git a/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml b/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
index 11dc5733d1a32d28e7139aaed2fd90266055673f..8c58aa15fbb266e1ad3660292a6b6d1c0f150b5e 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_high_arity.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f x x x x x x x x x x x x x = ()
 
 let g x = f x x x x x x x x

diff --git a/testsuite/tests/lib-dynlink-native/plugin_ref.ml b/testsuite/tests/lib-dynlink-native/plugin_ref.ml
index f025f6158f6af61c00c8ce1c07b3c1d169fb5ec3..60f127357c18c694e5f80e172e81854489c00d1e 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin_ref.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_ref.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let x = ref 0
 
 let () =

diff --git a/testsuite/tests/lib-dynlink-native/plugin_simple.ml b/testsuite/tests/lib-dynlink-native/plugin_simple.ml
index 1a609cc2de9746f4ef2b02b1ffc8660a11877db5..dd7d0226dfdd32e48cdcc204c92cc768ef9fd812 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin_simple.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_simple.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let facts = [ (Random.int 4) ]
 
 let () = print_endline "COUCOU"; print_char '\n'

diff --git a/testsuite/tests/lib-dynlink-native/plugin_thread.ml b/testsuite/tests/lib-dynlink-native/plugin_thread.ml
index 31481905ab1987f65bfbc22fb311740426ad0463..6e3d9d485a62fcbc437f933219950a296d050961 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin_thread.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin_thread.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   Api.reg_mod "Plugin_thread";
   let _t =

diff --git a/testsuite/tests/lib-dynlink-native/sub/api.ml b/testsuite/tests/lib-dynlink-native/sub/api.ml
index bb7b2eebf64848ddca4a6c54ea0f0d9a1a5fef4b..4a60586fc7271da5c5d84d612f2cd86fb32f8471 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/sub/api.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/api.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let f i =
   Printf.printf "Sub/api: f called with %i\n" i;
   i + 1

diff --git a/testsuite/tests/lib-dynlink-native/sub/api.mli b/testsuite/tests/lib-dynlink-native/sub/api.mli
index b374c00c78f195c648143b047ff2464d6410db8b..da5e52f2e27bb1b9c16121b48fc0cfbd67e46117 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/sub/api.mli
+++ b/testsuite/tests/lib-dynlink-native/sub/api.mli
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 val f : int -> int

diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin.ml b/testsuite/tests/lib-dynlink-native/sub/plugin.ml
index 5f183eb6cc987a4c6a0f972c75ff18b7da0ca6bd..d7faf9c8e276b89276426599a51c4ac4c7bbf633 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/sub/plugin.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/plugin.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec fact n = if n = 0 then 1 else n * fact (n - 1)
 
 let facts = [ fact 1; fact 2; fact 3; fact 4; fact 5 ]

diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
index b2d6ca5ea7302e1ef5dbfce9d70c22e9a7b6c426..82c9e4866ec3f1a6156c25b2ee68fd3ceef98fb4 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
+++ b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml
@@ -1,17 +1,2 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                         Alain Frisch, LexiFi                           *)
-(*                                                                        *)
-(*   Copyright 2007 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let () =
   ignore (Api.f 10)

diff --git a/testsuite/tests/lib-filename/Makefile b/testsuite/tests/lib-filename/Makefile
new file mode 100644 (file)
index 0000000..c11a415
--- /dev/null
+++ b/testsuite/tests/lib-filename/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-filename/extension.ml b/testsuite/tests/lib-filename/extension.ml
new file mode 100755 (executable)
index 0000000..917c014
--- /dev/null
+++ b/testsuite/tests/lib-filename/extension.ml
@@ -0,0 +1,14 @@
+let () =
+  let test f e =
+    assert(Filename.extension f = e);
+    assert(Filename.extension ("foo/" ^ f) = e);
+    assert(f = Filename.remove_extension f ^ Filename.extension f)
+  in
+  test "" "";
+  test "foo" "";
+  test "foo.txt" ".txt";
+  test "foo.txt.gz" ".gz";
+  test ".foo" "";
+  test "." "";
+  test ".." "";
+  test "foo..txt" ".txt"

diff --git a/testsuite/tests/lib-filename/extension.reference b/testsuite/tests/lib-filename/extension.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/lib-format/tformat.ml b/testsuite/tests/lib-format/tformat.ml
index ad0f16cc7356140aa130b1c81a74e8a3d56ba139..ee39a6a7cdd5c911f35f2ee90272b1d43e562a91 100644 (file)
--- a/testsuite/tests/lib-format/tformat.ml
+++ b/testsuite/tests/lib-format/tformat.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*         Pierre Weis, projet Pomdapi, INRIA Rocquencourt               *)
-(*                                                                       *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (*
 
 A test file for the Format module.

diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml
index 0ae427dfbae0e917439ed0f664800172d32832da..4fbb9cfe0517eaef3cd710538ec8dcd3f38941d0 100644 (file)
--- a/testsuite/tests/lib-hashtbl/hfun.ml
+++ b/testsuite/tests/lib-hashtbl/hfun.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Testing the hash function Hashtbl.hash *)
 (* What is tested:
      - reproducibility on various platforms, esp. 32/64 bit issues

diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml
index 12550f4d5c6763323b722e81f94a4fbdf0d8b321..106ee7932c63703ef5e14f0750dd02397bfd70fa 100644 (file)
--- a/testsuite/tests/lib-hashtbl/htbl.ml
+++ b/testsuite/tests/lib-hashtbl/htbl.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Hashtable operations, using maps as a reference *)
 
 open Printf

diff --git a/testsuite/tests/lib-marshal/intext.ml b/testsuite/tests/lib-marshal/intext.ml
index cffa55a1d89430d839572b685299ee32f4fdc1be..11633092fc8630ea8cfe51c6c6d0476300e64828 100644 (file)
--- a/testsuite/tests/lib-marshal/intext.ml
+++ b/testsuite/tests/lib-marshal/intext.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test for output_value / input_value *)
 
 let max_data_depth = 500000
@@ -329,8 +314,8 @@ let test_buffer () =
      with Failure s when s = "Marshal.to_buffer: buffer overflow" -> true)
 
 let test_size() =
-  let s = Marshal.to_string (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in
-  test 300 (Marshal.header_size + Marshal.data_size s 0 = String.length s)
+  let s = Marshal.to_bytes (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) [] in
+  test 300 (Marshal.header_size + Marshal.data_size s 0 = Bytes.length s)
 
 external marshal_to_block
    : string -> int -> 'a -> Marshal.extern_flags list -> unit
@@ -552,11 +537,48 @@ let test_mutual_rec_regression () =
   test 700 (try ignore (Marshal.to_string f [Marshal.Closures]); true
             with _ -> false)
 
+let test_end_of_file_regression () =
+  (* See PR#7142 *)
+  let write oc n =
+    for k = 0 to n - 1 do
+      Marshal.to_channel oc k []
+    done
+  in
+  let read ic n =
+    let k = ref 0 in
+    try
+      while true do
+        if Marshal.from_channel ic != !k then
+          failwith "unexpected integer";
+        incr k
+      done
+    with
+      | End_of_file when !k != n -> failwith "missing integer"
+      | End_of_file -> ()
+  in
+  test 800 (
+    try
+      let n = 100 in
+      let oc = open_out_bin "intext.data" in
+      write oc n;
+      close_out oc;
+
+      let ic = open_in_bin "intext.data" in
+      try
+        read ic n;
+        close_in ic;
+        true
+      with _ ->
+        close_in ic;
+        false
+    with _ -> false
+  )
+
+
 let main() =
   if Array.length Sys.argv <= 2 then begin
     test_out "intext.data"; test_in "intext.data";
     test_out "intext.data"; test_in "intext.data";
-    Sys.remove "intext.data";
     test_string();
     test_buffer();
     test_size();
@@ -565,6 +587,8 @@ let main() =
     test_objects();
     test_infix ();
     test_mutual_rec_regression ();
+    test_end_of_file_regression ();
+    Sys.remove "intext.data";
   end else
   if Sys.argv.(1) = "make" then begin
     let n = int_of_string Sys.argv.(2) in

diff --git a/testsuite/tests/lib-marshal/intext.reference b/testsuite/tests/lib-marshal/intext.reference
index af16fa3786c7692ff74d27733878399e6cbec0d5..412cea0ccdcf96baa04da01484937f31655a58f3 100644 (file)
--- a/testsuite/tests/lib-marshal/intext.reference
+++ b/testsuite/tests/lib-marshal/intext.reference
@@ -171,3 +171,4 @@ Test 605 passed.
 Test 606 passed.
 Test 607 passed.
 Test 700 passed.
+Test 800 passed.

diff --git a/testsuite/tests/lib-marshal/intextaux.c b/testsuite/tests/lib-marshal/intextaux.c
index a1a587adaf8866465d8970bbb04944fdff9d7918..f8df141efefd53d7545133d01ebf8a745fc98590 100644 (file)
--- a/testsuite/tests/lib-marshal/intextaux.c
+++ b/testsuite/tests/lib-marshal/intextaux.c
@@ -16,6 +16,8 @@
 #include <caml/mlvalues.h>
 #include <caml/intext.h>
 
+#define CAML_INTERNALS
+
 value marshal_to_block(value vbuf, value vlen, value v, value vflags)
 {
   return Val_long(output_value_to_block(v, vflags,

diff --git a/testsuite/tests/lib-num-2/pi_big_int.ml b/testsuite/tests/lib-num-2/pi_big_int.ml
index acf9af623e3fd120c0d19dfc0f82f47707c7fa49..22872ba4839de70d367efaf02247034bfcecd4f8 100644 (file)
--- a/testsuite/tests/lib-num-2/pi_big_int.ml
+++ b/testsuite/tests/lib-num-2/pi_big_int.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
-(*                                                                       *)
-(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (* Pi digits computed with the sreaming algorithm given on pages 4, 6
    & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
    Gibbons, August 2004. *)

diff --git a/testsuite/tests/lib-num-2/pi_num.ml b/testsuite/tests/lib-num-2/pi_num.ml
index a0651a87817a24c58667ca6b741aaac3e6bb2bc2..e2580c10bd58f642b271870153be1fb447f0840a 100644 (file)
--- a/testsuite/tests/lib-num-2/pi_num.ml
+++ b/testsuite/tests/lib-num-2/pi_num.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
-(*                                                                       *)
-(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (* Pi digits computed with the sreaming algorithm given on pages 4, 6
    & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
    Gibbons, August 2004. *)

diff --git a/testsuite/tests/lib-num/end_test.ml b/testsuite/tests/lib-num/end_test.ml
index aee100ae490aa70dbed4af2d74017d5e7448c0dc..57e099eda595d47dfc136821c3e0a8593ebf74b9 100644 (file)
--- a/testsuite/tests/lib-num/end_test.ml
+++ b/testsuite/tests/lib-num/end_test.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 Test.end_tests ();;

diff --git a/testsuite/tests/lib-num/test.ml b/testsuite/tests/lib-num/test.ml
index b4a4317ecabce0ba0f2dcd605c1d56e9af971d6d..b45d05d1fa3d2a373005acd142302ea21c75f05a 100644 (file)
--- a/testsuite/tests/lib-num/test.ml
+++ b/testsuite/tests/lib-num/test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf;;
 
 let flush_all () = flush stdout; flush stderr;;
@@ -90,6 +75,7 @@ let end_tests () =
 let eq = (==);;
 let eq_int (i: int) (j: int) = (i = j);;
 let eq_string (i: string) (j: string) = (i = j);;
+let eq_bytes (i: bytes) (j: bytes) = (i = j);;
 let eq_nativeint (i: nativeint) (j: nativeint) = (i = j);;
 let eq_int32 (i: int32) (j: int32) = (i = j);;
 let eq_int64 (i: int64) (j: int64) = (i = j);;

diff --git a/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml
index 9a99411f2b14e0a3396e46657404cf1fa7df8a35..61e4a9f2dfa695b9a3893b7041298998dcccee42 100644 (file)
--- a/testsuite/tests/lib-num/test_big_ints.ml
+++ b/testsuite/tests/lib-num/test_big_ints.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test;;
 open Nat;;
 open Big_int;;

diff --git a/testsuite/tests/lib-num/test_io.ml b/testsuite/tests/lib-num/test_io.ml
index eee3613ff14f38d31179d12d87016b4ee9188245..1df11a5fe6b2e1b2be7b5dd7869ca4ae595a97f5 100644 (file)
--- a/testsuite/tests/lib-num/test_io.ml
+++ b/testsuite/tests/lib-num/test_io.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test
 open Nat
 open Big_int

diff --git a/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml
index 770a786e8a2966d6e6c23b6a3e3eaa4b87e0c483..74ce5ecd1cd1707e0521ac08d430538574588e84 100644 (file)
--- a/testsuite/tests/lib-num/test_nats.ml
+++ b/testsuite/tests/lib-num/test_nats.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test;;
 open Nat;;
 
@@ -111,8 +96,7 @@ test 2 eq_string (string_of_nat n, "340282366920938463463374607431768211455");;
 testing_function "string_of_nat && nat_of_string";;
 
 for i = 1 to 20 do
-  let s = String.make i '0' in
-  String.set s 0 '1';
+  let s = String.init i (function 0 -> '1' | _ -> '0') in
   ignore (test i eq_string (string_of_nat (nat_of_string s), s))
 done;;
 

diff --git a/testsuite/tests/lib-num/test_nums.ml b/testsuite/tests/lib-num/test_nums.ml
index d78b6a96cb0c457efd36d6c89fde29fca9f4ee5f..e6cd5c9c73758504742cb846ad57b3c2acb27954 100644 (file)
--- a/testsuite/tests/lib-num/test_nums.ml
+++ b/testsuite/tests/lib-num/test_nums.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test;;
 open Nat;;
 open Big_int;;

diff --git a/testsuite/tests/lib-num/test_ratios.ml b/testsuite/tests/lib-num/test_ratios.ml
index bb62b835715588f47e156fdb367f31dcd0e34930..a5d8fe5eea0e20fce0362f22137b136271e33ebf 100644 (file)
--- a/testsuite/tests/lib-num/test_ratios.ml
+++ b/testsuite/tests/lib-num/test_ratios.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Test;;
 open Nat;;
 open Big_int;;
@@ -980,72 +965,72 @@ msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
 testing_function "round_futur_last_digit"
 ;;
 
-let s = "+123456" in
-test 1 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "+123456" in
+test 1 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             false) &&
-test 2 eq_string (s, "+123466")
+test 2 eq_bytes (s, Bytes.of_string "+123466")
 ;;
 
-let s = "123456" in
-test 3 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 4 eq_string (s, "123466")
+let s = Bytes.of_string "123456" in
+test 3 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 4 eq_bytes (s, Bytes.of_string "123466")
 ;;
 
-let s = "-123456" in
-test 5 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "-123456" in
+test 5 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             false) &&
-test 6 eq_string (s, "-123466")
+test 6 eq_bytes (s, Bytes.of_string "-123466")
 ;;
 
-let s = "+123496" in
-test 7 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "+123496" in
+test 7 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             false) &&
-test 8 eq_string (s, "+123506")
+test 8 eq_bytes (s, Bytes.of_string "+123506")
 ;;
 
-let s = "123496" in
-test 9 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 10 eq_string (s, "123506")
+let s = Bytes.of_string "123496" in
+test 9 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 10 eq_bytes (s, Bytes.of_string "123506")
 ;;
 
-let s = "-123496" in
-test 11 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "-123496" in
+test 11 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             false) &&
-test 12 eq_string (s, "-123506")
+test 12 eq_bytes (s, Bytes.of_string "-123506")
 ;;
 
-let s = "+996" in
-test 13 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "+996" in
+test 13 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
             true) &&
-test 14 eq_string (s, "+006")
+test 14 eq_bytes (s, Bytes.of_string "+006")
 ;;
 
-let s = "996" in
-test 15 eq (round_futur_last_digit s 0 (String.length s), true) &&
-test 16 eq_string (s, "006")
+let s = Bytes.of_string "996" in
+test 15 eq (round_futur_last_digit s 0 (Bytes.length s), true) &&
+test 16 eq_bytes (s, Bytes.of_string "006")
 ;;
 
-let s = "-996" in
-test 17 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "-996" in
+test 17 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
              true) &&
-test 18 eq_string (s, "-006")
+test 18 eq_bytes (s, Bytes.of_string "-006")
 ;;
 
-let s = "+6666666" in
-test 19 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "+6666666" in
+test 19 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
              false) &&
-test 20 eq_string (s, "+6666676")
+test 20 eq_bytes (s, Bytes.of_string "+6666676")
 ;;
 
-let s = "6666666" in
-test 21 eq (round_futur_last_digit s 0 (String.length s), false) &&
-test 22 eq_string (s, "6666676")
+let s = Bytes.of_string "6666666" in
+test 21 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
+test 22 eq_bytes (s, Bytes.of_string "6666676")
 ;;
 
-let s = "-6666666" in
-test 23 eq (round_futur_last_digit s 1 (pred (String.length s)),
+let s = Bytes.of_string "-6666666" in
+test 23 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
              false) &&
-test 24 eq_string (s, "-6666676")
+test 24 eq_bytes (s, Bytes.of_string "-6666676")
 ;;
 
 testing_function "approx_ratio_fix"

diff --git a/testsuite/tests/lib-obj/Makefile b/testsuite/tests/lib-obj/Makefile
new file mode 100755 (executable)
index 0000000..bb9cfba
--- /dev/null
+++ b/testsuite/tests/lib-obj/Makefile
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+MODULES=
+MAIN_MODULE=reachable_words
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-obj/reachable_words.ml b/testsuite/tests/lib-obj/reachable_words.ml
new file mode 100755 (executable)
index 0000000..68aeca4
--- /dev/null
+++ b/testsuite/tests/lib-obj/reachable_words.ml
@@ -0,0 +1,37 @@
+let native =
+  match Filename.basename Sys.argv.(0) with
+  | "program.byte" | "program.byte.exe" -> false
+  | "program.native" | "program.native.exe" -> true
+  | s -> print_endline s; assert false
+
+
+let size x = Obj.reachable_words (Obj.repr x)
+
+let expect_size s x =
+  let i = size x in
+  if i <> s then
+    Printf.printf "size = %i; expected = %i\n%!" i s
+
+type t =
+  | A of int
+  | B of t * t
+
+let f () =
+  let x = Random.int 10 in
+  expect_size 0 42;
+  expect_size (if native then 0 else 3) (1, 2);
+  expect_size 2 [| x |];
+  expect_size 3 [| x; 0 |];
+
+  let a = A x in
+  expect_size 2 a;
+  expect_size 5 (B (a, a)); (* sharing *)
+  expect_size 7 (B (a, A (x + 1)));
+
+  let rec b = B (a, b) in (* cycle *)
+  expect_size 5 b;
+
+  print_endline "OK"
+
+let () =
+  f ()

diff --git a/testsuite/tests/lib-obj/reachable_words.reference b/testsuite/tests/lib-obj/reachable_words.reference
new file mode 100644 (file)
index 0000000..d86bac9
--- /dev/null
+++ b/testsuite/tests/lib-obj/reachable_words.reference
@@ -0,0 +1 @@
+OK

diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml
index 1535d0e37ad4b56dc5f7dbc3a4c7bbc7dc30f803..4ab57230736b9281d22d1d99a8b0880b00efb6e5 100644 (file)
--- a/testsuite/tests/lib-printf/tprintf.ml
+++ b/testsuite/tests/lib-printf/tprintf.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
-(*                                                                       *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (*
 
 A test file for the Printf module.

diff --git a/testsuite/tests/lib-queue/test.ml b/testsuite/tests/lib-queue/test.ml
index d6acaa60f8284251f7c66e4cd067f7e3f493d799..5574abd8459625fb62f151f03ea6da7879aa1d8a 100644 (file)
--- a/testsuite/tests/lib-queue/test.ml
+++ b/testsuite/tests/lib-queue/test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module Q = struct
   include Queue
 

diff --git a/testsuite/tests/lib-random/rand.ml b/testsuite/tests/lib-random/rand.ml
index e8c5cb8bc7dde8182b153aedfe02c1dafa2a53bd..a05761ea7d3ba81c0358f1c188d97c30595e6990 100644 (file)
--- a/testsuite/tests/lib-random/rand.ml
+++ b/testsuite/tests/lib-random/rand.ml
@@ -1,6 +1,12 @@
+(* Test that two Random.self_init() in close succession will not result
+   in the same PRNG state.
+   Note that even when the code is correct this test is expected to fail
+   once in 10000 runs.
+*)
+
 let () =
   Random.self_init ();
   let x = Random.int 10000 in
   Random.self_init ();
-  let y = Random.int 1000 in
+  let y = Random.int 10000 in
   if x = y then print_endline "FAILED" else print_endline "PASSED"

diff --git a/testsuite/tests/lib-scanf-2/tscanf2_io.ml b/testsuite/tests/lib-scanf-2/tscanf2_io.ml
index 910df4963ad15ac8f760bba1764a7ad7c6dcec4c..03997897f82eeb74d9aed01bceba3b8c0950a291 100644 (file)
--- a/testsuite/tests/lib-scanf-2/tscanf2_io.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_io.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* A very simple communication module using buffers. It should help detecting
    advanced character reading by Scanf when using stdin. *)
 

diff --git a/testsuite/tests/lib-scanf-2/tscanf2_master.ml b/testsuite/tests/lib-scanf-2/tscanf2_master.ml
index 5d7ef316aafed92cb81537b6426f07b0329f0d45..2dd91bc0c8cc583701db3542e6b8826909150066 100644 (file)
--- a/testsuite/tests/lib-scanf-2/tscanf2_master.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_master.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* A very simple master:
    - first launch a slave process,
    - then repeat a random number of times:

diff --git a/testsuite/tests/lib-scanf-2/tscanf2_slave.ml b/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
index a890c6e2c1bab885ab78312bb1d79b7b0fd22800..e06a81f8144ccb107958ef165b40e589b2dd3816 100644 (file)
--- a/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
+++ b/testsuite/tests/lib-scanf-2/tscanf2_slave.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*              Pierre Weis, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2005 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* A very simple slave:
    - read the string " Ping" on stdin,
    - then print the string "-pong" on stderr,

diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml
index 5eb736d051f34f45029206d3d281c3fd201e2e76..421c1b408d03a9d14a6131db9dcfec094a36395b 100644 (file)
--- a/testsuite/tests/lib-scanf/tscanf.ml
+++ b/testsuite/tests/lib-scanf/tscanf.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                 OCaml                                 *)
-(*                                                                       *)
-(*            Pierre Weis, projet Cristal, INRIA Rocquencourt            *)
-(*                                                                       *)
-(*   Copyright 2002 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (*
 
 A testbed file for the module Scanf.

diff --git a/testsuite/tests/lib-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml
index b31456dfb6bfc61ed8a73b33baf351db2bea65d1..bbf4b06adaf8293cd38d49853a015911081c01d4 100644 (file)
--- a/testsuite/tests/lib-set/testmap.ml
+++ b/testsuite/tests/lib-set/testmap.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module M = Map.Make(struct type t = int let compare (x:t) y = compare x y end)
 
 let img x m = try Some(M.find x m) with Not_found -> None

diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml
index 6f92c095a5b7e9171fe0838f71951be2dff2c649..4417c36adb8a69b2469a4b4324071967f36af103 100644 (file)
--- a/testsuite/tests/lib-set/testset.ml
+++ b/testsuite/tests/lib-set/testset.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 module S = Set.Make(struct type t = int let compare (x:t) y = compare x y end)
 
 let testvals = [0;1;2;3;4;5;6;7;8;9]
@@ -75,6 +60,17 @@ let test x s1 s2 =
     (let b = S.subset s1 s2 in
      b || not (S.is_empty (S.diff s1 s2)));
 
+  checkbool "map"
+    (S.elements (S.map succ s1) = List.map succ (S.elements s1));
+
+  checkbool "map2"
+    (S.map (fun x -> x) s1 == s1);
+
+  checkbool "map3"
+    ((* check that the traversal is made in increasing element order *)
+     let last = ref min_int in
+     S.map (fun x -> assert (!last <= x); last := x; x) s1 == s1);
+
   checkbool "for_all"
     (let p x = x mod 2 = 0 in
      S.for_all p s1 = List.for_all p (S.elements s1));

diff --git a/testsuite/tests/lib-stack/test.ml b/testsuite/tests/lib-stack/test.ml
index e7423107b5919ab244e9f1dd32bcde86ce64924e..e0105c5032c483766ff00c540bdf3bbe67b2ffe4 100644 (file)
--- a/testsuite/tests/lib-stack/test.ml
+++ b/testsuite/tests/lib-stack/test.ml
@@ -1,15 +1,3 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*                 Jeremie Dimino, Jane Street Europe                  *)
-(*                                                                     *)
-(*  Copyright 2015 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the S Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
 module S = struct
   include Stack
 

diff --git a/testsuite/tests/lib-str/t01.ml b/testsuite/tests/lib-str/t01.ml
index 679141db4b4bd6f8d33810e150ababfbca20dd4e..1e1b270592e728aaed4572231814699287d16a05 100644 (file)
--- a/testsuite/tests/lib-str/t01.ml
+++ b/testsuite/tests/lib-str/t01.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 let build_result ngroups input =

diff --git a/testsuite/tests/lib-stream/count_concat_bug.ml b/testsuite/tests/lib-stream/count_concat_bug.ml
index 3779389175c2a7fa94048611b79114db5024cf2e..97ec6bce2019f86b7290bc8d963d977777d584d7 100644 (file)
--- a/testsuite/tests/lib-stream/count_concat_bug.ml
+++ b/testsuite/tests/lib-stream/count_concat_bug.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Gabriel Scherer, projet Gallium, INRIA Rocquencourt          *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let is_empty s =
   try Stream.empty s; true with Stream.Failure -> false
 

diff --git a/testsuite/tests/lib-string/test_string.ml b/testsuite/tests/lib-string/test_string.ml
index 8fe0521a95dce65ae8a9ad8f30e23026f8efd91e..96b8c50f77ea3d0898af472eda253fe3584a0e5c 100644 (file)
--- a/testsuite/tests/lib-string/test_string.ml
+++ b/testsuite/tests/lib-string/test_string.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                 Damien Doligez, Jane Street Group, LLC                 *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec build_string f n accu =
   if n <= 0
     then String.concat "" accu
@@ -36,3 +21,32 @@ let raw_string = build_string char 256 [];;
 let ref_string = build_string reference 256 [];;
 
 if String.escaped raw_string <> ref_string then failwith "test:String.escaped";;
+
+
+let check_split sep s =
+  let l = String.split_on_char sep s in
+  assert(List.length l > 0);
+  assert(String.concat (String.make 1 sep) l = s);
+  List.iter (String.iter (fun c -> assert (c <> sep))) l
+;;
+
+let () =
+  let s = " abc def " in
+  for i = 0 to String.length s do
+    check_split ' ' (String.sub s 0 i)
+  done
+;;
+
+(* GPR#805/815/833 *)
+
+let ()  =
+  if Sys.word_size = 32 then begin
+    let big = String.make Sys.max_string_length 'x' in
+    let push x l = l := x :: !l in
+    let (+=) a b = a := !a + b in
+    let sz, l = ref 0, ref [] in
+    while !sz >= 0 do push big l; sz += Sys.max_string_length done;
+    while !sz <= 0 do push big l; sz += Sys.max_string_length done;
+    try ignore (String.concat "" !l); assert false
+    with Invalid_argument _ -> ()
+  end

diff --git a/testsuite/tests/lib-systhreads/testfork.ml b/testsuite/tests/lib-systhreads/testfork.ml
index 2f019fa34a931b1630cbff2647b10f7431b10854..1c1f232fc91c4036acaa3868a802881d3981485e 100644 (file)
--- a/testsuite/tests/lib-systhreads/testfork.ml
+++ b/testsuite/tests/lib-systhreads/testfork.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* POSIX threads and fork() *)
 
 let compute_thread c = ignore c

diff --git a/testsuite/tests/lib-threads/bank.ml b/testsuite/tests/lib-threads/bank.ml
index 7474d983a5c8b31a15dbfa3046db692b0d2fc6a3..800d332a95ceac05bada15b0ad91cb2f699afc49 100644 (file)
--- a/testsuite/tests/lib-threads/bank.ml
+++ b/testsuite/tests/lib-threads/bank.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* The bank account example, using events and channels *)
 
 open Printf

diff --git a/testsuite/tests/lib-threads/beat.ml b/testsuite/tests/lib-threads/beat.ml
index f269baa7f675450a720ff2d03f57e78722b493c3..afc8166a2fda25cfeac4742ff6b01933c3eacd16 100644 (file)
--- a/testsuite/tests/lib-threads/beat.ml
+++ b/testsuite/tests/lib-threads/beat.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test Thread.delay and its scheduling *)
 
 open Printf

diff --git a/testsuite/tests/lib-threads/bufchan.ml b/testsuite/tests/lib-threads/bufchan.ml
index a686a94e5471e53444dc2b9834fbf1d5eb93d52d..b8ac55c2f70ca4203c6612bceecf8be12e7772bb 100644 (file)
--- a/testsuite/tests/lib-threads/bufchan.ml
+++ b/testsuite/tests/lib-threads/bufchan.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Event
 
 type 'a buffer_channel = {

diff --git a/testsuite/tests/lib-threads/close.ml b/testsuite/tests/lib-threads/close.ml
index ff6b2b06dded8306b5182388c2e6389baffc56a9..3af8ae313d9aad8d72445a2dfe2cbcde0026ae1f 100644 (file)
--- a/testsuite/tests/lib-threads/close.ml
+++ b/testsuite/tests/lib-threads/close.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let main () =
   let (rd, wr) = Unix.pipe() in
   let t = Thread.create

diff --git a/testsuite/tests/lib-threads/fileio.ml b/testsuite/tests/lib-threads/fileio.ml
index 370fee0a939768a3ba3c3ba69197b46c1cf4078c..f9d97c9436b6d8ae46d69f686bedee1ea0a50fed 100644 (file)
--- a/testsuite/tests/lib-threads/fileio.ml
+++ b/testsuite/tests/lib-threads/fileio.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test a file copy function *)
 
 let test msg producer consumer src dst =

diff --git a/testsuite/tests/lib-threads/pr4466.ml b/testsuite/tests/lib-threads/pr4466.ml
index 2f7092d7447bd2335f64837da1c8b51338500992..0598a54e1328ae16820c1546c3401d15f5895b5f 100644 (file)
--- a/testsuite/tests/lib-threads/pr4466.ml
+++ b/testsuite/tests/lib-threads/pr4466.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Regression test for PR#4466: select timeout with simultaneous read
@@ -27,9 +12,9 @@ open Printf
 *)
 
 let serve_connection s =
-  let buf = String.make 1024 '>' in
+  let buf = Bytes.make 1024 '>' in
   while true do
-    let n = Unix.recv s buf 2 (String.length buf - 2) [] in
+    let n = Unix.recv s buf 2 (Bytes.length buf - 2) [] in
     if n = 0 then begin
       Unix.close s; Thread.exit ()
     end else begin
@@ -44,24 +29,25 @@ let server sock =
   done
 
 let reader s =
-  let buf = String.make 16 ' ' in
+  let buf = Bytes.make 16 ' ' in
   match Unix.select [s] [] [] 10.0 with
   | (_::_, _, _) ->
       printf "Selected\n%!";
-      let n = Unix.recv s buf 0 (String.length buf) [] in
-      printf "Data read: %s\n%!" (String.sub buf 0 n)
+      let n = Unix.recv s buf 0 (Bytes.length buf) [] in
+      printf "Data read: %s\n%!" (Bytes.sub_string buf 0 n)
   | ([], _, _) ->
       printf "TIMEOUT\n%!"
 
 let writer s msg =
-  ignore (Unix.send s msg 0 (String.length msg) [])
+  ignore (Unix.send_substring s msg 0 (String.length msg) [])
 
 let _ =
-  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 9876) in
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
   let serv =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.setsockopt serv Unix.SO_REUSEADDR true;
   Unix.bind serv addr;
+  let addr = Unix.getsockname serv in
   Unix.listen serv 5;
   ignore (Thread.create server serv);
   Thread.delay 0.2;

diff --git a/testsuite/tests/lib-threads/pr5325.ml b/testsuite/tests/lib-threads/pr5325.ml
index 508eb4a4f1eca982a45859f703cf8cf2a101c51a..884a9a3ec9214af02f0340c3898e7d8bff7e6189 100644 (file)
--- a/testsuite/tests/lib-threads/pr5325.ml
+++ b/testsuite/tests/lib-threads/pr5325.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Paris                  *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Regression test for PR#5325: simultaneous read and write on socket
@@ -28,8 +13,8 @@ open Printf
 *)
 
 let serve_connection s =
-  let buf = String.make 1024 '>' in
-  let n = Unix.read s buf 2 (String.length buf - 2) in
+  let buf = Bytes.make 1024 '>' in
+  let n = Unix.read s buf 2 (Bytes.length buf - 2) in
   ignore (Unix.write s buf 0 (n + 2));
   Unix.close s
 
@@ -45,20 +30,21 @@ let timeout () =
   exit 2
 
 let reader s =
-  let buf = String.make 1024 ' ' in
-  let n = Unix.read s buf 0 (String.length buf) in
-  print_string (String.sub buf 0 n); flush stdout
+  let buf = Bytes.make 1024 ' ' in
+  let n = Unix.read s buf 0 (Bytes.length buf) in
+  print_bytes (Bytes.sub buf 0 n); flush stdout
 
 let writer s msg =
-  ignore (Unix.write s msg 0 (String.length msg));
+  ignore (Unix.write_substring s msg 0 (String.length msg));
   Unix.shutdown s Unix.SHUTDOWN_SEND
 
 let _ =
-  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 9876) in
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
   let serv =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.setsockopt serv Unix.SO_REUSEADDR true;
   Unix.bind serv addr;
+  let addr = Unix.getsockname serv in
   Unix.listen serv 5;
   ignore (Thread.create server serv);
   ignore (Thread.create timeout ());

diff --git a/testsuite/tests/lib-threads/prodcons.ml b/testsuite/tests/lib-threads/prodcons.ml
index e243ce0fbe0789b7d5afc342bce39fc8da281ef0..81e3ff185499c1e1ffca1b4db69a0123ce388d49 100644 (file)
--- a/testsuite/tests/lib-threads/prodcons.ml
+++ b/testsuite/tests/lib-threads/prodcons.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Classic producer-consumer *)
 
 type 'a prodcons =

diff --git a/testsuite/tests/lib-threads/prodcons2.ml b/testsuite/tests/lib-threads/prodcons2.ml
index 6133e07b4f2c5566c73927c241ac7a0fa0449e91..0b80f5e22786a5f79616713b959a934b44879d0c 100644 (file)
--- a/testsuite/tests/lib-threads/prodcons2.ml
+++ b/testsuite/tests/lib-threads/prodcons2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Producer-consumer with events and multiple producers *)
 
 open Event

diff --git a/testsuite/tests/lib-threads/sieve.ml b/testsuite/tests/lib-threads/sieve.ml
index 6cee51a13350fd559ce56cbf473c362c442974df..13c494cd292f05ad009fbc7776b6edd9e66cb1d9 100644 (file)
--- a/testsuite/tests/lib-threads/sieve.ml
+++ b/testsuite/tests/lib-threads/sieve.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let sieve primes =
   Event.sync (Event.send primes 2);
   let integers = Event.new_channel () in

diff --git a/testsuite/tests/lib-threads/sigint.c b/testsuite/tests/lib-threads/sigint.c
index 4a5cac632df54d7610e25e35836b8cedb1dc45ed..a975949add8bda126cc0264da5bbfb06368c4998 100644 (file)
--- a/testsuite/tests/lib-threads/sigint.c
+++ b/testsuite/tests/lib-threads/sigint.c
@@ -15,14 +15,14 @@ int main(int argc, char** argv)
   hProcess = OpenProcess(SYNCHRONIZE, FALSE, pid);
 
   if (!hProcess) {
-    printf("Process %ul not found!\n", pid);
+    printf("Process %lu not found!\n", pid);
     return 1;
   }
 
   FreeConsole();
 
   if (!AttachConsole(pid)) {
-    printf("Failed to attach to console of Process %ul\n", pid);
+    printf("Failed to attach to console of Process %lu\n", pid);
     CloseHandle(hProcess);
     return 1;
   }

diff --git a/testsuite/tests/lib-threads/signal.ml b/testsuite/tests/lib-threads/signal.ml
index e067ea06fdf047f4a32820f50ea62b3a555afa19..b9ef7d63ca9b170f5d96ebaaf31e7b4e1d08da84 100644 (file)
--- a/testsuite/tests/lib-threads/signal.ml
+++ b/testsuite/tests/lib-threads/signal.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let sighandler _ =
   print_string "Got ctrl-C, exiting..."; print_newline();
   exit 0

diff --git a/testsuite/tests/lib-threads/signal2.ml b/testsuite/tests/lib-threads/signal2.ml
index 79e984e2bb3f4037538407da9172cfc98c60d44e..b7cda56df70c9f08b3c09a0875b5bb143844a8e8 100644 (file)
--- a/testsuite/tests/lib-threads/signal2.ml
+++ b/testsuite/tests/lib-threads/signal2.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let print_message delay c =
   while true do
     print_char c; flush stdout; Thread.delay delay

diff --git a/testsuite/tests/lib-threads/sockets.ml b/testsuite/tests/lib-threads/sockets.ml
index b4adec36e75afe9224ea61a3bc681113577bfda7..160446f604ddd1f00bdcf07aa05b9b6194fca4a1 100644 (file)
--- a/testsuite/tests/lib-threads/sockets.ml
+++ b/testsuite/tests/lib-threads/sockets.ml
@@ -1,25 +1,10 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Threads and sockets *)
 
 let serve_connection s =
-  let buf = String.make 1024 '>' in
-  let n = Unix.read s buf 2 (String.length buf - 2) in
+  let buf = Bytes.make 1024 '>' in
+  let n = Unix.read s buf 2 (Bytes.length buf - 2) in
   Thread.delay 1.0;
   ignore (Unix.write s buf 0 (n + 2));
   Unix.close s
@@ -34,17 +19,18 @@ let client (addr, msg) =
   let sock =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.connect sock addr;
-  let buf = String.make 1024 ' ' in
-  ignore(Unix.write sock msg 0 (String.length msg));
-  let n = Unix.read sock buf 0 (String.length buf) in
-  print_string (String.sub buf 0 n); flush stdout
+  let buf = Bytes.make 1024 ' ' in
+  ignore(Unix.write_substring sock msg 0 (String.length msg));
+  let n = Unix.read sock buf 0 (Bytes.length buf) in
+  print_bytes (Bytes.sub buf 0 n); flush stdout
 
 let _ =
-  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 9876) in
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
   let sock =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.setsockopt sock Unix.SO_REUSEADDR true;
   Unix.bind sock addr;
+  let addr = Unix.getsockname sock in
   Unix.listen sock 5;
   ignore (Thread.create server sock);
   ignore (Thread.create client (addr, "Client #1\n"));

diff --git a/testsuite/tests/lib-threads/socketsbuf.ml b/testsuite/tests/lib-threads/socketsbuf.ml
index d23d33e3d9ecc222540fb3c80bae7406f4ca8aa4..7eafb1bdb6025cbccba64e1cb328a0dd71784392 100644 (file)
--- a/testsuite/tests/lib-threads/socketsbuf.ml
+++ b/testsuite/tests/lib-threads/socketsbuf.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf
 
 (* Threads, sockets, and buffered I/O channels *)
@@ -42,11 +27,12 @@ let client (addr, msg) =
   printf "%s\n%!" l
 
 let _ =
-  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 9876) in
+  let addr = Unix.ADDR_INET(Unix.inet_addr_loopback, 0) in
   let sock =
     Unix.socket (Unix.domain_of_sockaddr addr) Unix.SOCK_STREAM 0 in
   Unix.setsockopt sock Unix.SO_REUSEADDR true;
   Unix.bind sock addr;
+  let addr = Unix.getsockname sock in
   Unix.listen sock 5;
   ignore (Thread.create server sock);
   ignore (Thread.create client (addr, "Client #1\n"));

diff --git a/testsuite/tests/lib-threads/swapchan.ml b/testsuite/tests/lib-threads/swapchan.ml
index 8074b610c63b95921537eadd20db628814c38ec5..1f80beb8f8e4dc477e685d59839e18a84d47e17f 100644 (file)
--- a/testsuite/tests/lib-threads/swapchan.ml
+++ b/testsuite/tests/lib-threads/swapchan.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Event
 
 type 'a swap_chan = ('a * 'a channel) channel

diff --git a/testsuite/tests/lib-threads/tls.ml b/testsuite/tests/lib-threads/tls.ml
index 0f51b9d52c8264b9890a1329b52945297f3139db..6db93fa902021f0368aeb358727a4c4f1c74386c 100644 (file)
--- a/testsuite/tests/lib-threads/tls.ml
+++ b/testsuite/tests/lib-threads/tls.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let private_data = (Hashtbl.create 17 : (Thread.t, string) Hashtbl.t)
 let private_data_lock = Mutex.create()
 let output_lock = Mutex.create()

diff --git a/testsuite/tests/lib-threads/torture.ml b/testsuite/tests/lib-threads/torture.ml
index 82908d24e8f4d6bb57f61c3e51111519f4c5e715..9dba8addcd17b05fccb0f1cc149b9782f22ab489 100644 (file)
--- a/testsuite/tests/lib-threads/torture.ml
+++ b/testsuite/tests/lib-threads/torture.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Torture test - I/O interspersed with lots of GC *)
 
 let finished = ref false
@@ -27,21 +12,21 @@ let gc_thread () =
 let writer_thread (oc, size) =
   while not !finished do
 (*    print_string "writer "; print_int size; print_newline(); *)
-    let buff = String.make size 'a' in
+    let buff = Bytes.make size 'a' in
     ignore(Unix.write oc buff 0 size)
   done;
-  let buff = String.make size 'b' in
+  let buff = Bytes.make size 'b' in
   ignore (Unix.write oc buff 0 size)
 
 let reader_thread (ic, size) =
   while true do
 (*    print_string "reader "; print_int size; print_newline(); *)
-    let buff = String.make size ' ' in
+    let buff = Bytes.make size ' ' in
     let n = Unix.read ic buff 0 size in
 (*    print_string "reader "; print_int n; print_newline(); *)
     for i = 0 to n-1 do
-      if buff.[i] = 'b' then Thread.exit()
-      else if buff.[i] <> 'a' then print_string "error in reader_thread\n"
+      if Bytes.get buff i = 'b' then Thread.exit()
+      else if Bytes.get buff i <> 'a' then print_string "error in reader_thread\n"
     done
   done
 

diff --git a/testsuite/tests/lib-uchar/test.ml b/testsuite/tests/lib-uchar/test.ml
index f7e37725c9a46306cd22fd1d15725d1c6926aa09..a2b7ec1decfeee3f5f5aec7766d02b2f81a1e071 100644 (file)
--- a/testsuite/tests/lib-uchar/test.ml
+++ b/testsuite/tests/lib-uchar/test.ml
@@ -1,19 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                            Daniel C. Buenzli                           *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-
 let assert_raise_invalid_argument f v =
   assert (try ignore (f v); false with Invalid_argument _ -> true)
 

diff --git a/testsuite/tests/link-test/Makefile b/testsuite/tests/link-test/Makefile
index d1ee0c24fd480e5d191d92c5f132a6ddf7687b86..8ac2e18b90221ba7f40e6dde2d120be811b1c7e0 100644 (file)
--- a/testsuite/tests/link-test/Makefile
+++ b/testsuite/tests/link-test/Makefile
@@ -14,22 +14,45 @@
 #*                                                                        *
 #**************************************************************************
 
-default:
-       printf " ... testing 'test.reference':"
+default: byte native
+
+native:
+       @printf " ... testing native 'test.reference':"
        @$(OCAMLOPT) -c submodule.ml
        @$(OCAMLOPT) -c aliases.ml
+       @$(OCAMLOPT) -c external.mli external.ml
+       @$(OCAMLOPT) -c external_for_pack.mli external_for_pack.ml
        @$(OCAMLOPT) -c test.ml
-       @$(OCAMLOPT) -a submodule.cmx aliases.cmx -o mylib.cmxa
-       @$(OCAMLOPT) mylib.cmxa test.cmx -o test.native
+       @$(OCAMLOPT) -a submodule.cmx aliases.cmx external.cmx \
+               external_for_pack.cmx -o mylib.cmxa
+       @$(OCAMLOPT) -c -for-pack P use_in_pack.ml
+       @$(OCAMLOPT) -pack use_in_pack.cmx -o p.cmx
+       @$(OCAMLOPT) mylib.cmxa p.cmx test.cmx -o test.native
        @./test.native > test.result
        @$(DIFF) test.result test.reference >/dev/null \
            && echo " => passed" || echo " => failed"
 
+byte:
+       @printf " ... testing byte 'test.reference':"
+       @$(OCAMLC) -c submodule.ml
+       @$(OCAMLC) -c aliases.ml
+       @$(OCAMLC) -c external.mli external.ml
+       @$(OCAMLC) -c external_for_pack.mli external_for_pack.ml
+       @$(OCAMLC) -c test.ml
+       @$(OCAMLC) -a submodule.cmo aliases.cmo external.cmo \
+               external_for_pack.cmo -o mylib.cma
+       @$(OCAMLC) -c -for-pack P use_in_pack.ml
+       @$(OCAMLC) -pack use_in_pack.cmo -o p.cmo
+       @$(OCAMLC) mylib.cma p.cmo test.cmo -o test.byte
+       @$(OCAMLRUN) ./test.byte > test.result
+       @$(DIFF) test.result test.reference >/dev/null \
+           && echo " => passed" || echo " => failed"
+
 promote: defaultpromote
 
 clean: defaultclean
        @rm -f *.result
-       @rm -f test.native
+       @rm -f test.native test.byte
 
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/link-test/external.ml b/testsuite/tests/link-test/external.ml
new file mode 100644 (file)
index 0000000..e2eb5b7
--- /dev/null
+++ b/testsuite/tests/link-test/external.ml
@@ -0,0 +1,2 @@
+let () = print_endline "linked external"; flush stdout
+external frexp : float -> float * int = "caml_frexp_float"

diff --git a/testsuite/tests/link-test/external.mli b/testsuite/tests/link-test/external.mli
new file mode 100644 (file)
index 0000000..4b2548e
--- /dev/null
+++ b/testsuite/tests/link-test/external.mli
@@ -0,0 +1 @@
+external frexp : float -> float * int = "caml_frexp_float"

diff --git a/testsuite/tests/link-test/external_for_pack.ml b/testsuite/tests/link-test/external_for_pack.ml
new file mode 100644 (file)
index 0000000..2d5be97
--- /dev/null
+++ b/testsuite/tests/link-test/external_for_pack.ml
@@ -0,0 +1,2 @@
+let () = print_endline "linked external from pack"; flush stdout
+external frexp : float -> float * int = "caml_frexp_float"

diff --git a/testsuite/tests/link-test/external_for_pack.mli b/testsuite/tests/link-test/external_for_pack.mli
new file mode 100644 (file)
index 0000000..4b2548e
--- /dev/null
+++ b/testsuite/tests/link-test/external_for_pack.mli
@@ -0,0 +1 @@
+external frexp : float -> float * int = "caml_frexp_float"

diff --git a/testsuite/tests/link-test/test.ml b/testsuite/tests/link-test/test.ml
index 80190b83b89a08d1280d534164b490d5c1e7e752..24d870ac28dce916f138184205cf26f0ed747a62 100644 (file)
--- a/testsuite/tests/link-test/test.ml
+++ b/testsuite/tests/link-test/test.ml
@@ -1 +1,2 @@
 include Aliases.Submodule.M
+let _, _ = External.frexp 3.

diff --git a/testsuite/tests/link-test/test.reference b/testsuite/tests/link-test/test.reference
index 1fb9bdd646436e1e339bfee0555af1f2f52f1be3..b188f6c0d566ac6bd09f5a56fa8c7c7091df7f22 100644 (file)
--- a/testsuite/tests/link-test/test.reference
+++ b/testsuite/tests/link-test/test.reference
@@ -1 +1,3 @@
 linked
+linked external
+linked external from pack

diff --git a/testsuite/tests/link-test/use_in_pack.ml b/testsuite/tests/link-test/use_in_pack.ml
new file mode 100644 (file)
index 0000000..9d55b59
--- /dev/null
+++ b/testsuite/tests/link-test/use_in_pack.ml
@@ -0,0 +1 @@
+let _, _ = External_for_pack.frexp 12.

diff --git a/testsuite/tests/manual-intf-c/Makefile b/testsuite/tests/manual-intf-c/Makefile
new file mode 100644 (file)
index 0000000..4601ff9
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/Makefile
@@ -0,0 +1,40 @@
+# Tests from manual, section intf-c
+# main.ml: error message when equality is missing
+# main_ok.ml: allow path expansion even when the target is missing (GPR#816)
+
+SOURCES = curses.ml prog.ml
+CSOURCES = curses_stubs.c
+CLIBS = -cclib "$(BYTECCLIBS)"
+LIBUNIX = -I $(BASEDIR)/../otherlibs/unix unix.cma
+
+# Disable this test until we figure out how to test for the availability
+# of curses.
+.PHONY: disable
+disable:
+       @printf " ... testing prog => skipped\n"
+       @printf " ... testing prog2 => skipped\n"
+
+.PHONY: default
+default: clean $(SOURCES) $(CSOURCES)
+       @printf " ... testing prog"
+       @$(MAKE) prog > /dev/null && echo " => passed" || echo " => failed"
+       @printf " ... testing prog2"
+       @$(MAKE) prog2 REDIRECT=">prog2.result 2>&1" \
+         >/dev/null 2>/dev/null || :
+       @$(DIFF) prog2.reference prog2.result >/dev/null \
+       && echo " => passed" || echo " => failed"
+
+# Should succeed
+prog:
+       $(OCAMLC) -custom -o prog $(LIBUNIX) $(SOURCES) $(CSOURCES) $(CLIBS)
+
+# Should fail
+prog2:  curses.cmo
+       $(OCAMLC) -custom -o prog2 $(LIBUNIX) prog.ml $(CSOURCES) $(CLIBS) $(REDIRECT)
+
+.PHONY: clean
+clean:
+       @rm -f *.cm* *.o *~ prog prog2
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/manual-intf-c/curses.ml b/testsuite/tests/manual-intf-c/curses.ml
new file mode 100644 (file)
index 0000000..1447f6b
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/curses.ml
@@ -0,0 +1,13 @@
+(* File curses.ml -- declaration of primitives and data types *)
+type window                   (* The type "window" remains abstract *)
+external initscr: unit -> window = "caml_curses_initscr"
+external endwin: unit -> unit = "caml_curses_endwin"
+external refresh: unit -> unit = "caml_curses_refresh"
+external wrefresh : window -> unit = "caml_curses_wrefresh"
+external newwin: int -> int -> int -> int -> window = "caml_curses_newwin"
+external addch: char -> unit = "caml_curses_addch"
+external mvwaddch: window -> int -> int -> char -> unit = "caml_curses_mvwaddch"
+external addstr: string -> unit = "caml_curses_addstr"
+external mvwaddstr: window -> int -> int -> string -> unit
+         = "caml_curses_mvwaddstr"
+(* lots more omitted *)

diff --git a/testsuite/tests/manual-intf-c/curses_stubs.c b/testsuite/tests/manual-intf-c/curses_stubs.c
new file mode 100644 (file)
index 0000000..33c74a8
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/curses_stubs.c
@@ -0,0 +1,94 @@
+/* File curses_stubs.c -- stub code for curses */
+#include <curses.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+/* Encapsulation of opaque window handles (of type WINDOW *)
+   as OCaml custom blocks. */
+
+static struct custom_operations curses_window_ops = {
+  "fr.inria.caml.curses_windows",
+  custom_finalize_default,
+  custom_compare_default,
+  custom_hash_default,
+  custom_serialize_default,
+  custom_deserialize_default,
+  custom_compare_ext_default
+};
+
+/* Accessing the WINDOW * part of an OCaml custom block */
+#define Window_val(v) (*((WINDOW **) Data_custom_val(v)))
+
+/* Allocating an OCaml custom block to hold the given WINDOW * */
+static value alloc_window(WINDOW * w)
+{
+  value v = alloc_custom(&curses_window_ops, sizeof(WINDOW *), 0, 1);
+  Window_val(v) = w;
+  return v;
+}
+
+value caml_curses_initscr(value unit)
+{
+  CAMLparam1 (unit);
+  CAMLreturn (alloc_window(initscr()));
+}
+
+value caml_curses_endwin(value unit)
+{
+  CAMLparam1 (unit);
+  endwin();
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_refresh(value unit)
+{
+  CAMLparam1 (unit);
+  refresh();
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_wrefresh(value win)
+{
+  CAMLparam1 (win);
+  wrefresh(Window_val(win));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_newwin(value nlines, value ncols, value x0, value y0)
+{
+  CAMLparam4 (nlines, ncols, x0, y0);
+  CAMLreturn (alloc_window(newwin(Int_val(nlines), Int_val(ncols),
+                                  Int_val(x0), Int_val(y0))));
+}
+
+value caml_curses_addch(value c)
+{
+  CAMLparam1 (c);
+  addch(Int_val(c));            /* Characters are encoded like integers */
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_mvwaddch(value win, value x, value y, value c)
+{
+  CAMLparam4 (win, x, y, c);
+  mvwaddch(Window_val(win), Int_val(x), Int_val(y), Int_val(c));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_addstr(value s)
+{
+  CAMLparam1 (s);
+  addstr(String_val(s));
+  CAMLreturn (Val_unit);
+}
+
+value caml_curses_mvwaddstr(value win, value x, value y, value s)
+{
+  CAMLparam4 (win, x, y, s);
+  mvwaddstr(Window_val(win), Int_val(x), Int_val(y), String_val(s));
+  CAMLreturn (Val_unit);
+}
+
+/* This goes on for pages. */

diff --git a/testsuite/tests/manual-intf-c/prog.ml b/testsuite/tests/manual-intf-c/prog.ml
new file mode 100644 (file)
index 0000000..a913fd9
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/prog.ml
@@ -0,0 +1,9 @@
+(* File prog.ml -- main program using curses *)
+open Curses;;
+let main_window = initscr () in
+let small_window = newwin 10 5 20 10 in
+  mvwaddstr main_window 10 2 "Hello";
+  mvwaddstr small_window 4 3 "world";
+  refresh();
+  Unix.sleep 5;
+  endwin()

diff --git a/testsuite/tests/manual-intf-c/prog2.reference b/testsuite/tests/manual-intf-c/prog2.reference
new file mode 100644 (file)
index 0000000..06f5553
--- /dev/null
+++ b/testsuite/tests/manual-intf-c/prog2.reference
@@ -0,0 +1,2 @@
+File "curses_stubs.c", line 1:
+Error: Required module `Curses' is unavailable

diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference
index f1e30bc56c4eef24e04e8208d7d84bc5c6e5714d..69ba3a45f7fe4c87b19f836d1b0c60ec41a38ca5 100644 (file)
--- a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference
+++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference
@@ -5,7 +5,7 @@
       | Some false -> ()
       | None -> ()
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some true
 val test_match_exhaustiveness : unit -> unit = <fun>
 # 

diff --git a/testsuite/tests/misc-kb/equations.ml b/testsuite/tests/misc-kb/equations.ml
index 6e28aa082ef343e7bf02720ba740f612e0edbb68..c8dbff05053cc3819c7fd1c9159a467ea000f527 100644 (file)
--- a/testsuite/tests/misc-kb/equations.ml
+++ b/testsuite/tests/misc-kb/equations.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (****************** Equation manipulations *************)
 
 open Terms

diff --git a/testsuite/tests/misc-kb/equations.mli b/testsuite/tests/misc-kb/equations.mli
index 81a6ec454e228ff0ee2686fbffdd3b27137b41e3..99055ce22a8c232b51f6c56b4bd5c3c61de7c117 100644 (file)
--- a/testsuite/tests/misc-kb/equations.mli
+++ b/testsuite/tests/misc-kb/equations.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 
 type rule =

diff --git a/testsuite/tests/misc-kb/kb.ml b/testsuite/tests/misc-kb/kb.ml
index bb0e43910f2404dce33d8362f1767ab195d6bf77..1e5fd2c714d7cb4bd814b201a9eca6e735317cd3 100644 (file)
--- a/testsuite/tests/misc-kb/kb.ml
+++ b/testsuite/tests/misc-kb/kb.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 open Equations
 

diff --git a/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli
index 78bbba5c78e216543489dd1f8aedec81b3f99243..3276871656796df866aca6999e2315d6b7bbe359 100644 (file)
--- a/testsuite/tests/misc-kb/kb.mli
+++ b/testsuite/tests/misc-kb/kb.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 open Equations
 

diff --git a/testsuite/tests/misc-kb/kbmain.ml b/testsuite/tests/misc-kb/kbmain.ml
index b8aff7ce323baf722ef2f0e560ce1130c49bb5a2..e5c53dc82cb81cbe1b00f04021a0f075b8e7e8cf 100644 (file)
--- a/testsuite/tests/misc-kb/kbmain.ml
+++ b/testsuite/tests/misc-kb/kbmain.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 open Equations
 open Orderings

diff --git a/testsuite/tests/misc-kb/orderings.ml b/testsuite/tests/misc-kb/orderings.ml
index 2646e8354912bb3263d1f4fae2f91e6bb0a9c762..b6ef8abf599f51b0b70c9e0e4c1a0cc6bf3e197c 100644 (file)
--- a/testsuite/tests/misc-kb/orderings.ml
+++ b/testsuite/tests/misc-kb/orderings.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (*********************** Recursive Path Ordering ****************************)
 
 open Terms

diff --git a/testsuite/tests/misc-kb/orderings.mli b/testsuite/tests/misc-kb/orderings.mli
index 2bc41e967c43610ac671ba340f2bf1140124f5ac..d0493c5228301dcf37233e5c1b0b61f08c76479a 100644 (file)
--- a/testsuite/tests/misc-kb/orderings.mli
+++ b/testsuite/tests/misc-kb/orderings.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Terms
 
 type ordering =

diff --git a/testsuite/tests/misc-kb/terms.ml b/testsuite/tests/misc-kb/terms.ml
index b1e95311abaf7d1ab7e505e63badfe16420eac2a..f66c86fab2ac71bbd4020f94a2bd25358cb9f32c 100644 (file)
--- a/testsuite/tests/misc-kb/terms.ml
+++ b/testsuite/tests/misc-kb/terms.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (****************** Term manipulations *****************)
 
 type term =

diff --git a/testsuite/tests/misc-kb/terms.mli b/testsuite/tests/misc-kb/terms.mli
index 90da1a8c8e6778b2fb58303be8039578f269913d..81ec58e726ca0989eea6e81286fffe185b5e6c49 100644 (file)
--- a/testsuite/tests/misc-kb/terms.mli
+++ b/testsuite/tests/misc-kb/terms.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type term =
     Var of int
   | Term of string * term list

diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml
index 3e3024ee1126930ded1de93a0c2ecb1c48fed824..7c030a8539c71ff0005d1111a4967465b485f5d7 100644 (file)
--- a/testsuite/tests/misc-unsafe/fft.ml
+++ b/testsuite/tests/misc-unsafe/fft.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let pi = 3.14159265358979323846
 
 let tpi = 2.0 *. pi

diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml
index 9835d6993f0b013b1233eda60c22bd2ae682ad5a..21491b70a6f54aadcaf00344f8e5051454051c27 100644 (file)
--- a/testsuite/tests/misc-unsafe/quicksort.ml
+++ b/testsuite/tests/misc-unsafe/quicksort.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Good test for loops. Best compiled with -unsafe. *)
 
 let rec qsort lo hi (a : int array) =

diff --git a/testsuite/tests/misc-unsafe/soli.ml b/testsuite/tests/misc-unsafe/soli.ml
index bdf1e1ed75a5cf56852c3c6031995b6a954c5ba7..ccab81e09681f68778e20e7697ba87156607fc74 100644 (file)
--- a/testsuite/tests/misc-unsafe/soli.ml
+++ b/testsuite/tests/misc-unsafe/soli.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type peg = Out | Empty | Peg
 
 let board = [|

diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml
index 684202ada8a2c7e0f6f2a93f21094105aaa906f4..ce7d931db338c7468e5a8ad7d51160e04fa59da0 100644 (file)
--- a/testsuite/tests/misc/bdd.ml
+++ b/testsuite/tests/misc/bdd.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Translated to OCaml by Xavier Leroy *)
 (* Original code written in SML by ... *)
 

diff --git a/testsuite/tests/misc/boyer.ml b/testsuite/tests/misc/boyer.ml
index 257cdea8b90cdeb0c2cfd7a7d18cf2cdeaa43683..38b0a4bd5f321fd523cdd7577390782cdd863774 100644 (file)
--- a/testsuite/tests/misc/boyer.ml
+++ b/testsuite/tests/misc/boyer.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Manipulations over terms *)
 
 type term =

diff --git a/testsuite/tests/misc/ephetest.ml b/testsuite/tests/misc/ephetest.ml
index 6aa9ca01f384abf1444fbbab2cf544ca43c67d3c..a125300c17c45e4a5248c18acfea1e287a66f808 100644 (file)
--- a/testsuite/tests/misc/ephetest.ml
+++ b/testsuite/tests/misc/ephetest.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
-(*                                                                       *)
-(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 let debug = false
 
 open Printf

diff --git a/testsuite/tests/misc/ephetest2.ml b/testsuite/tests/misc/ephetest2.ml
index d1da448657a2d2997d3f7cf8dccf3f8144e71b9b..61861df99601fc79b023fc5d71e0f957fc9c5b77 100644 (file)
--- a/testsuite/tests/misc/ephetest2.ml
+++ b/testsuite/tests/misc/ephetest2.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
-(*                                                                       *)
-(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (***
    This test evaluate boolean formula composed by conjunction and
      disjunction using ephemeron:

diff --git a/testsuite/tests/misc/ephetest3.ml b/testsuite/tests/misc/ephetest3.ml
index 3c49b47fe0308569160f32be83c3f1eb790371bc..5eed2cf3b49e418bdf1b558b00d0573941685228 100644 (file)
--- a/testsuite/tests/misc/ephetest3.ml
+++ b/testsuite/tests/misc/ephetest3.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
-(*                                                                       *)
-(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 (** This test weak table by application to the memoization of collatz
     (also known as syracuse) algorithm suite computation *)
 

diff --git a/testsuite/tests/misc/fib.ml b/testsuite/tests/misc/fib.ml
index 5c7c9dc272ae493fe86e0307e78a783e9d0c5f62..15228173e33e9ba7e745acc2e44a3241b07833b1 100644 (file)
--- a/testsuite/tests/misc/fib.ml
+++ b/testsuite/tests/misc/fib.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec fib n =
   if n < 2 then 1 else fib(n-1) + fib(n-2)
 

diff --git a/testsuite/tests/misc/finaliser.ml b/testsuite/tests/misc/finaliser.ml
new file mode 100644 (file)
index 0000000..316c0da
--- /dev/null
+++ b/testsuite/tests/misc/finaliser.ml
@@ -0,0 +1,68 @@
+
+
+let m = 1000
+let m' = 100
+let k = m*10
+
+(** the printing are not stable between ocamlc and ocamlopt *)
+let debug = false
+
+let gc_print where _ =
+  if debug then
+    let stat = Gc.quick_stat () in
+    Printf.printf "minor: %i major: %i %s\n%!"
+      stat.Gc.minor_collections
+      stat.Gc.major_collections
+      where
+
+let r = Array.init m (fun _ -> Array.make m 1)
+
+
+let () =
+  gc_print "[Before]" ();
+  let rec aux n =
+    if n < k then begin
+      r.(n mod m) <- (Array.make m' n);
+      begin match n mod m with
+      | 0 ->
+          (** finalise first major *)
+          gc_print (Printf.sprintf "[Create %i first]" n) ();
+          Gc.finalise (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(0)
+      | 1 ->
+          (** finalise last major *)
+          gc_print (Printf.sprintf "[Create %i last]" n) ();
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i last]" n)) r.(1)
+      | 2 ->
+          (** finalise first minor *)
+          let m = ref 1 in
+          gc_print (Printf.sprintf "[Create %i first minor]" n) ();
+          Gc.finalise
+            (gc_print (Printf.sprintf "[Finalise %i first minor]" n)) m
+      | 3 ->
+          (** finalise last minor *)
+          let m = ref 1 in
+          gc_print (Printf.sprintf "[Create %i last minor]" n) ();
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i last minor]" n)) m
+      | 4 ->
+          (** finalise first-last major *)
+          gc_print (Printf.sprintf "[Create %i first]" n) ();
+          Gc.finalise (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(4);
+          Gc.finalise_last
+            (gc_print (Printf.sprintf "[Finalise %i first]" n)) r.(4)
+      | _ -> ()
+      end;
+      aux (n + 1)
+    end
+  in
+  aux 0;
+  gc_print "[Full major]" ();
+  Gc.full_major ();
+  gc_print "[Second full major]" ();
+  Gc.full_major ();
+  gc_print "[Third full major]" ();
+  Gc.full_major ();
+  ()
+
+let () = flush stdout

diff --git a/testsuite/tests/misc/finaliser.reference b/testsuite/tests/misc/finaliser.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/misc/hamming.ml b/testsuite/tests/misc/hamming.ml
index 885d2752c5a1188145dca323a2a7637eafe8477f..c98dea3df88fc4e91270ab23450519e75f4aa6ec 100644 (file)
--- a/testsuite/tests/misc/hamming.ml
+++ b/testsuite/tests/misc/hamming.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* We cannot use bignums because we don't do custom runtimes, but
    int64 is a bit short, so we roll our own 37-digit numbers...
 *)

diff --git a/testsuite/tests/misc/nucleic.ml b/testsuite/tests/misc/nucleic.ml
index 55647e15a210f5bb7cb744a7357d5bd5a865e6a9..a31b41664cf3f04cbc5c71e7386e3f22115f34a6 100644 (file)
--- a/testsuite/tests/misc/nucleic.ml
+++ b/testsuite/tests/misc/nucleic.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Use floating-point arithmetic *)
 
 external (+) : float -> float -> float = "%addfloat"

diff --git a/testsuite/tests/misc/sieve.ml b/testsuite/tests/misc/sieve.ml
index 54df6e28b346ef7ae8e9c42676affa7a5d4fbb0c..0b9ac4c92bb46f0e9579bce3e6d72cb9b925066f 100644 (file)
--- a/testsuite/tests/misc/sieve.ml
+++ b/testsuite/tests/misc/sieve.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Eratosthene's sieve *)
 
 (* interval min max = [min; min+1; ...; max-1; max] *)

diff --git a/testsuite/tests/misc/sorts.ml b/testsuite/tests/misc/sorts.ml
index 40a0fbb2e1c0d646dc882ebe6a9a5ad7bd1265a3..4c4d7126d6c042e3837ea20d96d161ab93b1cadd 100644 (file)
--- a/testsuite/tests/misc/sorts.ml
+++ b/testsuite/tests/misc/sorts.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Test bench for sorting algorithms. *)
 
 
@@ -135,8 +120,8 @@ let chkfloats rstate n a =
 ;;
 
 type record = {
-  s1 : string;
-  s2 : string;
+  s1 : bytes;
+  s2 : bytes;
   i1 : int;
   i2 : int;
 };;

diff --git a/testsuite/tests/misc/takc.ml b/testsuite/tests/misc/takc.ml
index 8fec8984e5072994d537b1fa4658dbae9cbb83cb..dbb17e2acebb0f19615dd8e4154e46f467a77f3c 100644 (file)
--- a/testsuite/tests/misc/takc.ml
+++ b/testsuite/tests/misc/takc.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec tak x y z =
   if x > y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
            else z

diff --git a/testsuite/tests/misc/taku.ml b/testsuite/tests/misc/taku.ml
index 647266c8ad54b592753f50b492eb6168aeb4a76a..6a6753b393fb1f4c7f89e16bf733688fea253042 100644 (file)
--- a/testsuite/tests/misc/taku.ml
+++ b/testsuite/tests/misc/taku.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec tak (x, y, z) =
   if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
            else z

diff --git a/testsuite/tests/misc/weaklifetime.ml b/testsuite/tests/misc/weaklifetime.ml
index d6b23f3d22b37fed73d7c7424b2ee72e0075a72c..a05c1623052c4d8c9b069954fab60c9a51f7010b 100644 (file)
--- a/testsuite/tests/misc/weaklifetime.ml
+++ b/testsuite/tests/misc/weaklifetime.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*                 Damien Doligez, Jane Street Group, LLC                *)
-(*                                                                       *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 Random.init 12345;;
 
 let size = 1000;;

diff --git a/testsuite/tests/misc/weaklifetime2.ml b/testsuite/tests/misc/weaklifetime2.ml
index 4e18640ea9e6d8bd70babb430b940c1fc4052484..59f9ef4cdfdb614e88cdae386132d50349be2033 100644 (file)
--- a/testsuite/tests/misc/weaklifetime2.ml
+++ b/testsuite/tests/misc/weaklifetime2.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*                 Damien Doligez, Jane Street Group, LLC                *)
-(*                                                                       *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 let n = 500
 let loop = 2
 

diff --git a/testsuite/tests/misc/weaktest.ml b/testsuite/tests/misc/weaktest.ml
index ffeabf29eff186daff44c8064d8a46e83d0e904c..a8e4b08431537102f543e351fde810985520d41c 100644 (file)
--- a/testsuite/tests/misc/weaktest.ml
+++ b/testsuite/tests/misc/weaktest.ml
@@ -1,15 +1,3 @@
-(*************************************************************************)
-(*                                                                       *)
-(*                                OCaml                                  *)
-(*                                                                       *)
-(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
-(*                                                                       *)
-(*   Copyright 2008 Institut National de Recherche en Informatique et    *)
-(*   en Automatique.  All rights reserved.  This file is distributed     *)
-(*   under the terms of the Q Public License version 1.0.                *)
-(*                                                                       *)
-(*************************************************************************)
-
 let debug = false;;
 
 open Printf;;
@@ -38,11 +26,7 @@ let bunch =
 Random.init 314;;
 
 let random_string n =
-  let result = String.create n in
-  for i = 0 to n - 1 do
-    result.[i] <- Char.chr (32 + Random.int 95);
-  done;
-  result
+  String.init n (fun _ -> Char.chr (32 + Random.int 95))
 ;;
 
 let added = ref 0;;

diff --git a/testsuite/tests/no-alias-deps/aliases.cmo.reference b/testsuite/tests/no-alias-deps/aliases.cmo.reference
index dd1907146b9e6f5d602cbf54b261f849c0c6b69d..b236b1dcd3b10a864e8b2e33e6b31ce9ec767571 100644 (file)
--- a/testsuite/tests/no-alias-deps/aliases.cmo.reference
+++ b/testsuite/tests/no-alias-deps/aliases.cmo.reference
@@ -8,5 +8,8 @@ Interfaces imported:
        --------------------------------        B
        aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa        Aliases
        --------------------------------        A
+Required globals:
+       D
+       Pervasives
 Uses unsafe features: no
 Force link: no

diff --git a/testsuite/tests/parsetree/Makefile b/testsuite/tests/parsetree/Makefile
new file mode 100644 (file)
index 0000000..8e917a0
--- /dev/null
+++ b/testsuite/tests/parsetree/Makefile
@@ -0,0 +1,23 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/parsing
+MODULES=
+MAIN_MODULE=test
+LIBRARIES=../../../compilerlibs/ocamlcommon
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml
new file mode 100644 (file)
index 0000000..be2d5b9
--- /dev/null
+++ b/testsuite/tests/parsetree/source.ml
@@ -0,0 +1,7256 @@
+[@@@foo]
+
+let (x[@foo]) : unit [@foo] = ()[@foo]
+  [@@foo]
+
+type t =
+  | Foo of (t[@foo]) [@foo]
+[@@foo]
+
+[@@@foo]
+
+
+module M = struct
+  type t = {
+    l : (t [@foo]) [@foo]
+  }
+    [@@foo]
+    [@@foo]
+
+  [@@@foo]
+end[@foo]
+[@@foo]
+
+module type S = sig
+
+  include (module type of (M[@foo]))[@foo] with type t := M.t[@foo]
+    [@@foo]
+
+  [@@@foo]
+
+end[@foo]
+[@@foo]
+
+[@@@foo]
+type 'a with_default
+  =  ?size:int       (** default [42] *)
+  -> ?resizable:bool (** default [true] *)
+  -> 'a
+
+type obj = <
+  meth1 : int -> int;
+  (** method 1 *)
+
+  meth2: unit -> float (** method 2 *);
+>
+
+type var = [
+  | `Foo (** foo *)
+  | `Bar of int * string (** bar *)
+]
+
+[%%foo let x = 1 in x]
+let [%foo 2+1] : [%foo bar.baz] = [%foo "foo"]
+
+[%%foo module M = [%bar] ]
+let [%foo let () = () ] : [%foo type t = t ] = [%foo class c = object end]
+
+[%%foo: 'a list]
+let [%foo: [`Foo] ] : [%foo: t -> t ] = [%foo: < foo : t > ]
+
+[%%foo? _ ]
+[%%foo? Some y when y > 0]
+let [%foo? (Bar x | Baz x) ] : [%foo? #bar ] = [%foo? { x }]
+
+[%%foo: module M : [%baz]]
+let [%foo: include S with type t = t ]
+  : [%foo: val x : t  val y : t]
+  = [%foo: type t = t ]
+let int_with_custom_modifier =
+  1234567890_1234567890_1234567890_1234567890_1234567890z
+let float_with_custom_modifier =
+  1234567890_1234567890_1234567890_1234567890_1234567890.z
+
+let int32     = 1234l
+let int64     = 1234L
+let nativeint = 1234n
+
+let hex_without_modifier = 0x32f
+let hex_with_modifier    = 0x32g
+
+let float_without_modifer = 1.2e3
+let float_with_modifer    = 1.2g
+let%foo x = 42
+let%foo _ = () and _ = ()
+let%foo _ = ()
+
+(* Expressions *)
+let () =
+  let%foo[@foo] x = 3
+  and[@foo] y = 4 in
+  (let module%foo[@foo] M = M in ()) ;
+  (let open%foo[@foo] M in ()) ;
+  (fun%foo[@foo] x -> ()) ;
+  (function%foo[@foo] x -> ()) ;
+  (try%foo[@foo] () with _ -> ()) ;
+  (if%foo[@foo] () then () else ()) ;
+  while%foo[@foo] () do () done ;
+  for%foo[@foo] x = () to () do () done ;
+  assert%foo[@foo] true ;
+  lazy%foo[@foo] x ;
+  object%foo[@foo] end ;
+  begin%foo[@foo] 3 end ;
+  new%foo[@foo] x ;
+
+  match%foo[@foo] () with
+  (* Pattern expressions *)
+  | lazy%foo[@foo] x -> ()
+  | exception%foo[@foo] x -> ()
+
+(* Class expressions *)
+class x =
+  fun[@foo] x ->
+  let[@foo] x = 3 in
+  object[@foo]
+    inherit[@foo] x
+    val[@foo] x = 3
+    val[@foo] virtual x : t
+    val![@foo] mutable x = 3
+    method[@foo] x = 3
+    method[@foo] virtual x : t
+    method![@foo] private x = 3
+    initializer[@foo] x
+  end
+
+(* Class type expressions *)
+class type t =
+  object[@foo]
+    inherit[@foo] t
+    val[@foo] x : t
+    val[@foo] mutable x : t
+    method[@foo] x : t
+    method[@foo] private x : t
+    constraint[@foo] t = t'
+    [@@@abc]
+    [%%id]
+    [@@@aaa]
+  end
+
+(* Type expressions *)
+type t =
+  (module%foo[@foo] M)
+
+(* Module expressions *)
+module M =
+  functor[@foo] (M : S) ->
+    (val[@foo] x)
+    (struct[@foo] end)
+
+(* Module type expression *)
+module type S =
+  functor[@foo] (M:S) ->
+    (module type of[@foo] M) ->
+    (sig[@foo] end)
+
+(* Structure items *)
+let%foo[@foo] x = 4
+and[@foo] y = x
+
+type%foo[@foo] t = int
+and[@foo] t = int
+type%foo[@foo] t += T
+
+class%foo[@foo] x = x
+class type%foo[@foo] x = x
+external%foo[@foo] x : _  = ""
+exception%foo[@foo] X
+
+module%foo[@foo] M = M
+module%foo[@foo] rec M : S = M
+and[@foo] M : S = M
+module type%foo[@foo] S = S
+
+include%foo[@foo] M
+open%foo[@foo] M
+
+(* Signature items *)
+module type S = sig
+  val%foo[@foo] x : t
+  external%foo[@foo] x : t = ""
+
+  type%foo[@foo] t = int
+  and[@foo] t' = int
+  type%foo[@foo] t += T
+
+  exception%foo[@foo] X
+
+  module%foo[@foo] M : S
+  module%foo[@foo] rec M : S
+  and[@foo] M : S
+  module%foo[@foo] M = M
+
+  module type%foo[@foo] S = S
+
+  include%foo[@foo] M
+  open%foo[@foo] M
+
+  class%foo[@foo] x : t
+  class type%foo[@foo] x = x
+
+end
+
+type t = ..;;
+type t += A;;
+
+[%extension_constructor A];;
+([%extension_constructor A] : extension_constructor);;
+
+module M = struct
+  type extension_constructor = int
+end;;
+
+open M;;
+
+([%extension_constructor A] : extension_constructor);;
+
+(* By using two types we can have a recursive constraint *)
+type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..>
+and 'a name =
+  Class : 'a class_name -> (< cast: 'a. 'a name -> 'a; ..> as 'a) name
+;;
+
+exception Bad_cast
+;;
+
+class type castable =
+object
+  method cast: 'a.'a name -> 'a
+end
+;;
+
+(* Lets create a castable class with a name*)
+
+class type foo_t =
+object
+  inherit castable
+  method foo: string
+end
+;;
+
+type 'a class_name += Foo: foo_t class_name
+;;
+
+class foo: foo_t =
+object(self)
+  method cast: type a. a name -> a =
+    function
+        Class Foo -> (self :> foo_t)
+      | _ -> ((raise Bad_cast) : a)
+  method foo = "foo"
+end
+;;
+
+(* Now we can create a subclass of foo *)
+
+class type bar_t =
+object
+  inherit foo
+  method bar: string
+end
+;;
+
+type 'a class_name += Bar: bar_t class_name
+;;
+
+class bar: bar_t =
+object(self)
+  inherit foo as super
+  method cast: type a. a name -> a =
+    function
+        Class Bar -> (self :> bar_t)
+      | other -> super#cast other
+  method bar = "bar"
+  [@@@id]
+  [%%id]
+end
+;;
+
+(* Now lets create a mutable list of castable objects *)
+
+let clist :castable list ref = ref []
+;;
+
+let push_castable (c: #castable) =
+  clist := (c :> castable) :: !clist
+;;
+
+let pop_castable () =
+  match !clist with
+      c :: rest ->
+        clist := rest;
+        c
+    | [] -> raise Not_found
+;;
+
+(* We can add foos and bars to this list, and retrive them *)
+
+push_castable (new foo);;
+push_castable (new bar);;
+push_castable (new foo);;
+
+let c1: castable = pop_castable ();;
+let c2: castable = pop_castable ();;
+let c3: castable = pop_castable ();;
+
+(* We can also downcast these values to foos and bars *)
+
+let f1: foo = c1#cast (Class Foo);; (* Ok *)
+let f2: foo = c2#cast (Class Foo);; (* Ok *)
+let f3: foo = c3#cast (Class Foo);; (* Ok *)
+
+let b1: bar = c1#cast (Class Bar);; (* Exception Bad_cast *)
+let b2: bar = c2#cast (Class Bar);; (* Ok *)
+let b3: bar = c3#cast (Class Bar);; (* Exception Bad_cast *)
+
+type foo = ..
+;;
+
+type foo +=
+    A
+  | B of int
+;;
+
+let is_a x =
+  match x with
+    A -> true
+  | _ -> false
+;;
+
+(* The type must be open to create extension *)
+
+type foo
+;;
+
+type foo += A of int (* Error type is not open *)
+;;
+
+(* The type parameters must match *)
+
+type 'a foo = ..
+;;
+
+type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
+;;
+
+(* In a signature the type does not have to be open *)
+
+module type S =
+sig
+  type foo
+  type foo += A of float
+end
+;;
+
+(* But it must still be extensible *)
+
+module type S =
+sig
+  type foo = A of int
+  type foo += B of float (* Error foo does not have an extensible type *)
+end
+;;
+
+(* Signatures can change the grouping of extensions *)
+
+type foo = ..
+;;
+
+module M = struct
+  type foo +=
+      A of int
+    | B of string
+
+  type foo +=
+      C of int
+    | D of float
+end
+;;
+
+module type S = sig
+  type foo +=
+      B of string
+    | C of int
+
+  type foo += D of float
+
+  type foo += A of int
+end
+;;
+
+module M_S = (M : S)
+;;
+
+(* Extensions can be GADTs *)
+
+type 'a foo = ..
+;;
+
+type _ foo +=
+    A : int -> int foo
+  | B : int foo
+;;
+
+let get_num : type a. a foo -> a -> a option = fun f i1 ->
+    match f with
+        A i2 -> Some (i1 + i2)
+     |  _ -> None
+;;
+
+(* Extensions must obey constraints *)
+
+type 'a foo = .. constraint 'a = [> `Var ]
+;;
+
+type 'a foo += A of 'a
+;;
+
+let a = A 9 (* ERROR: Constraints not met *)
+;;
+
+type 'a foo += B : int foo (* ERROR: Constraints not met *)
+;;
+
+(* Signatures can make an extension private *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A of int end
+;;
+
+let a1 = M.A 10
+;;
+
+module type S = sig type foo += private A of int end
+;;
+
+module M_S = (M : S)
+;;
+
+let is_s x =
+  match x with
+    M_S.A _ -> true
+  | _ -> false
+;;
+
+let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *)
+;;
+
+(* Extensions can be rebound *)
+
+type foo = ..
+;;
+
+module M = struct type foo += A1 of int end
+;;
+
+type foo += A2 = M.A1
+;;
+
+type bar = ..
+;;
+
+type bar += A3 = M.A1    (* Error: rebind wrong type *)
+;;
+
+module M = struct type foo += private B1 of int end
+;;
+
+type foo += private B2 = M.B1
+;;
+
+type foo += B3 = M.B1  (* Error: rebind private extension *)
+;;
+
+type foo += C = Unknown  (* Error: unbound extension *)
+;;
+
+(* Extensions can be rebound even if type is closed *)
+
+module M : sig type foo type foo += A1 of int end
+  = struct type foo = .. type foo += A1 of int end
+
+type M.foo += A2 = M.A1
+
+(* Rebinding handles abbreviations *)
+
+type 'a foo = ..
+;;
+
+type 'a foo1 = 'a foo = ..
+;;
+
+type 'a foo2 = 'a foo = ..
+;;
+
+type 'a foo1 +=
+    A of int
+  | B of 'a
+  | C : int foo1
+;;
+
+type 'a foo2 +=
+    D = A
+  | E = B
+  | F = C
+;;
+
+(* Extensions must obey variances *)
+
+type +'a foo = ..
+;;
+
+type 'a foo += A of (int -> 'a)
+;;
+
+type 'a foo += B of ('a -> int)
+    (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type _ foo += C : ('a -> int) -> 'a foo
+    (* ERROR: Parameter variances are not satisfied *)
+;;
+
+type 'a bar = ..
+;;
+
+type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *)
+;;
+
+(* Exceptions are compatible with extensions *)
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end
+;;
+
+module M : sig
+  exception Bar : 'a list -> exn
+  exception Foo of int * float
+end = struct
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end
+;;
+
+exception Foo of int * float
+;;
+
+exception Bar : 'a list -> exn
+;;
+
+module M : sig
+  type exn +=
+      Foo of int * float
+    | Bar : 'a list -> exn
+end = struct
+  exception Bar = Bar
+  exception Foo = Foo
+end
+;;
+
+(* Test toplevel printing *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo of int * int option
+  | Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar but not Foo (which has been shadowed) *)
+;;
+
+exception Foo of int * int option
+;;
+
+exception Bar of int option
+;;
+
+let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *)
+;;
+
+type foo += Foo of string
+;;
+
+let y = x (* Prints Bar and part of Foo (which has been shadowed) *)
+;;
+
+(* Test Obj functions *)
+
+type foo = ..
+;;
+
+type foo +=
+    Foo
+  | Bar of int
+;;
+
+let extension_name e = Obj.extension_name (Obj.extension_constructor e);;
+let extension_id e = Obj.extension_id (Obj.extension_constructor e);;
+
+let n1 = extension_name Foo
+;;
+
+let n2 = extension_name (Bar 1)
+;;
+
+let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *)
+;;
+
+let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *)
+;;
+
+let is_foo x = (extension_id Foo) = (extension_id x)
+
+type foo += Foo
+;;
+
+let f = is_foo Foo
+;;
+
+let _ = Obj.extension_constructor 7 (* Invald_arg *)
+;;
+
+let _ = Obj.extension_constructor (object method m = 3 end) (* Invald_arg *)
+;;
+(* Typed names *)
+
+module Msg : sig
+
+  type 'a tag
+
+  type result = Result : 'a tag * 'a -> result
+
+  val write : 'a tag -> 'a -> unit
+
+  val read : unit -> result
+
+  type 'a tag += Int : int tag
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) : sig
+    type 'a tag += C : D.t tag
+  end
+
+end = struct
+
+  type 'a tag = ..
+
+  type ktag = T : 'a tag -> ktag
+
+  type 'a kind =
+  { tag : 'a tag;
+    label : string;
+    write : 'a -> string;
+    read : string -> 'a; }
+
+  type rkind = K : 'a kind -> rkind
+
+  type wkind = { f : 'a . 'a tag -> 'a kind }
+
+  let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13
+
+  let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13
+
+  let read_raw () : string * string = raise (Failure "Not implemented")
+
+  type result = Result : 'a tag * 'a -> result
+
+  let read () =
+    let label, content = read_raw () in
+      let K k = Hashtbl.find readTbl label in
+        let body = k.read content in
+          Result(k.tag, body)
+
+  let write_raw (label : string) (content : string) =
+    raise (Failure "Not implemented")
+
+  let write (tag : 'a tag) (body : 'a) =
+    let {f} = Hashtbl.find writeTbl (T tag) in
+    let k = f tag in
+    let content = k.write body in
+      write_raw k.label content
+
+  (* Add int kind *)
+
+  type 'a tag += Int : int tag
+
+  let ik =
+    { tag = Int;
+      label = "int";
+      write = string_of_int;
+      read = int_of_string }
+
+  let () = Hashtbl.add readTbl "int" (K ik)
+
+  let () =
+    let f (type t) (i : t tag) : t kind =
+      match i with
+        Int -> ik
+      | _ -> assert false
+    in
+      Hashtbl.add writeTbl (T Int) {f}
+
+  (* Support user defined kinds *)
+
+  module type Desc = sig
+    type t
+    val label : string
+    val write : t -> string
+    val read : string -> t
+  end
+
+  module Define (D : Desc) = struct
+    type 'a tag += C : D.t tag
+    let k =
+      { tag = C;
+        label = D.label;
+        write = D.write;
+        read = D.read }
+    let () = Hashtbl.add readTbl D.label (K k)
+    let () =
+      let f (type t) (c : t tag) : t kind =
+        match c with
+          C -> k
+        | _ -> assert false
+      in
+        Hashtbl.add writeTbl (T C) {f}
+  end
+
+end;;
+
+let write_int i = Msg.write Msg.Int i;;
+
+module StrM = Msg.Define(struct
+  type t = string
+  let label = "string"
+  let read s = s
+  let write s = s
+end);;
+
+type 'a Msg.tag += String = StrM.C;;
+
+let write_string s = Msg.write String s;;
+
+let read_one () =
+  let Msg.Result(tag, body) = Msg.read () in
+  match tag with
+    Msg.Int -> print_int body
+  | String -> print_string body
+  | _ -> print_string "Unknown";;
+(* Example of algorithm parametrized with modules *)
+
+let sort (type s) set l =
+  let module Set = (val set : Set.S with type elt = s) in
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+let make_set (type s) cmp =
+  let module S = Set.Make(struct
+    type t = s
+    let compare = cmp
+  end) in
+  (module S : Set.S with type elt = s)
+
+let both l =
+  List.map
+    (fun set -> sort set l)
+    [ make_set compare; make_set (fun x y -> compare y x) ]
+
+let () =
+  print_endline (String.concat "  " (List.map (String.concat "/")
+                                              (both ["abc";"xyz";"def"])))
+
+
+(* Hiding the internal representation *)
+
+module type S = sig
+  type t
+  val to_string: t -> string
+  val apply: t -> t
+  val x: t
+end
+
+let create (type s) to_string apply x =
+  let module M = struct
+    type t = s
+    let to_string = to_string
+    let apply = apply
+    let x = x
+  end in
+  (module M : S with type t = s)
+
+let forget (type s) x =
+  let module M = (val x : S with type t = s) in
+  (module M : S)
+
+let print x =
+  let module M = (val x : S) in
+  print_endline (M.to_string M.x)
+
+let apply x =
+  let module M = (val x : S) in
+  let module N = struct
+    include M
+    let x = apply x
+  end in
+  (module N : S)
+
+let () =
+  let int = forget (create string_of_int succ 0) in
+  let str = forget (create (fun s -> s) (fun s -> s ^ s) "X") in
+  List.iter print (List.map apply [int; apply int; apply (apply str)])
+
+
+(* Existential types + type equality witnesses -> pseudo GADT *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = unit
+  let apply _ = Obj.magic
+  let refl = ()
+  let sym () = ()
+end
+
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t
+    type t1
+    type t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = struct
+  module type PAIR = sig
+    type t
+    type t1
+    type t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end
+
+open Typ
+
+let int = Int TypEq.refl
+
+let str = String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  let pair = (module P : PAIR with type t = s1 * s2) in
+  Pair pair
+
+module rec Print : sig
+  val to_string: 'a Typ.typ -> 'a -> string
+end = struct
+  let to_string (type s) t x =
+    match t with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair p ->
+        let module P = (val p : PAIR with type t = s) in
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (Print.to_string P.t1 x1)
+                       (Print.to_string P.t2 x2)
+end
+
+let () =
+  print_endline (Print.to_string int 10);
+  print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456)))
+
+
+(* #6262: first-class modules and module type aliases *)
+
+module type S1 = sig end
+module type S2 = S1
+
+let _f (x : (module S1)) : (module S2) = x
+
+module X = struct
+  module type S
+end
+module Y = struct include X end
+
+let _f (x : (module X.S)) : (module Y.S) = x
+
+(* PR#6194, main example *)
+module type S3 = sig val x : bool end;;
+let f = function
+  | Some (module M : S3) when M.x ->1
+  | Some _ [@foooo]-> 2
+  | None -> 3
+;;
+print_endline (string_of_int (f (Some (module struct let x = false end))));;
+type 'a ty =
+  | Int : int ty
+  | Bool : bool ty
+
+let fbool (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> x
+;;
+(* val fbool : 'a -> 'a ty -> 'a = <fun> *)
+(** OK: the return value is x of type t **)
+
+let fint (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Int -> x > 0
+;;
+(* val fint : 'a -> 'a ty -> bool = <fun> *)
+(** OK: the return value is x > 0 of type bool;
+This has used the equation t = bool, not visible in the return type **)
+
+let f (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Int -> x > 0
+  | Bool -> x
+(* val f : 'a -> 'a ty -> bool = <fun> *)
+
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> x
+  | Int -> x > 0
+(* Error: This expression has type bool but an expression was expected of type
+t = int *)
+
+let id x = x;;
+let idb1 = (fun id -> let _ = id true in id) id;;
+let idb2 : bool -> bool = id;;
+let idb3 ( _ : bool ) = false;;
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> idb3 x
+  | Int -> x > 0
+
+let g (type t) (x : t) (tag : t ty) =
+  match tag with
+  | Bool -> idb2 x
+  | Int -> x > 0
+(* Encoding generics using GADTs *)
+(* (c) Alain Frisch / Lexifi *)
+(* cf. http://www.lexifi.com/blog/dynamic-types *)
+
+(* Basic tag *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+;;
+
+(* Tagging data *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+
+exception VariantMismatch
+
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | _ -> raise VariantMismatch
+;;
+
+(* Handling records *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: 'a record -> 'a ty
+
+and 'a record =
+    {
+     path: string;
+     fields: 'a field_ list;
+    }
+
+and 'a field_ =
+  | Field: ('a, 'b) field -> 'a field_
+
+and ('a, 'b) field =
+    {
+     label: string;
+     field_type: 'b ty;
+     get: ('a -> 'b);
+    }
+;;
+
+(* Again *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+    | Record {fields} ->
+        VRecord
+          (List.map (fun (Field{field_type; label; get}) ->
+                       (label, variantize field_type (get x))) fields)
+;;
+
+(* Extraction *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: ('a, 'builder) record -> 'a ty
+
+and ('a, 'builder) record =
+    {
+     path: string;
+     fields: ('a, 'builder) field list;
+     create_builder: (unit -> 'builder);
+     of_builder: ('builder -> 'a);
+    }
+
+and ('a, 'builder) field =
+  | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+
+and ('a, 'builder, 'b) field_ =
+  {
+   label: string;
+   field_type: 'b ty;
+   get: ('a -> 'b);
+   set: ('builder -> 'b -> unit);
+  }
+
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | Record {fields; create_builder; of_builder}, VRecord fl ->
+        if List.length fields <> List.length fl then raise VariantMismatch;
+        let builder = create_builder () in
+        List.iter2
+          (fun (Field {label; field_type; set}) (lab, v) ->
+            if label <> lab then raise VariantMismatch;
+            set builder (devariantize field_type v)
+          )
+          fields fl;
+        of_builder builder
+    | _ -> raise VariantMismatch
+;;
+
+type my_record  =
+    {
+     a: int;
+     b: string list;
+    }
+
+let my_record =
+  let fields =
+    [
+     Field {label = "a"; field_type = Int;
+            get = (fun {a} -> a);
+            set = (fun (r, _) x -> r := Some x)};
+     Field {label = "b"; field_type = List String;
+            get = (fun {b} -> b);
+            set = (fun (_, r) x -> r := Some x)};
+    ]
+  in
+  let create_builder () = (ref None, ref None) in
+  let of_builder (a, b) =
+    match !a, !b with
+    | Some a, Some b -> {a; b}
+    | _ -> failwith "Some fields are missing in record of type my_record"
+  in
+  Record {path = "My_module.my_record"; fields; create_builder; of_builder}
+;;
+
+(* Extension to recursive types and polymorphic variants *)
+(* by Jacques Garrigue *)
+
+type noarg = Noarg
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  (* Support for type variables and recursive types *)
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  (* Change the representation of a type *)
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  (* Sum types (both normal sums and polymorphic variants) *)
+  | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+
+and ('a, 'e, 'b) ty_sum =
+    { sum_proj: 'a -> string * 'e ty_dyn option;
+      sum_cases: (string * ('e,'b) ty_case) list;
+      sum_inj: 'c. ('b,'c) ty_sel * 'c -> 'a; }
+
+and 'e ty_dyn =              (* dynamic type *)
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =           (* selector from a list of types *)
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =          (* type a sum case *)
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+type _ ty_env =              (* type variable substitution *)
+  | Enil : unit ty_env
+  | Econs : ('a,'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+;;
+
+(* Comparing selectors *)
+type (_,_) eq = Eq: ('a,'a) eq
+
+let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
+  fun s1 s2 ->
+    match s1, s2 with
+    | Thd, Thd -> Some Eq
+    | Ttl s1, Ttl s2 ->
+        (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq)
+    | _ -> None
+
+(* Auxiliary function to get the type of a case from its selector *)
+let rec get_case : type a b e.
+  (b, a) ty_sel -> (string * (e,b) ty_case) list -> string * (a, e) ty option =
+  fun sel cases ->
+  match cases with
+  | (name, TCnoarg sel') :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, None
+      end
+  | (name, TCarg (sel', ty)) :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, Some ty
+      end
+  | [] -> raise Not_found
+;;
+
+(* Untyped representation of values *)
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+
+let may_map f = function Some x -> Some (f x) | None -> None
+
+let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
+  fun e ty v ->
+  match ty with
+  | Int -> VInt v
+  | String -> VString v
+  | List t -> VList (List.map (variantize e t) v)
+  | Option t -> VOption (may_map (variantize e t) v)
+  | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v))
+  | Rec t -> variantize (Econs (ty, e)) t v
+  | Pop t -> (match e with Econs (_, e') -> variantize e' t v)
+  | Var -> (match e with Econs (t, e') -> variantize e' t v)
+  | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v))
+  | Sum ops ->
+      let tag, arg = ops.sum_proj v in
+      VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg)
+;;
+
+let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
+  fun e ty v ->
+  match ty, v with
+  | Int, VInt x -> x
+  | String, VString x -> x
+  | List ty1, VList vl ->
+      List.map (devariantize e ty1) vl
+  | Pair (ty1, ty2), VPair (x1, x2) ->
+      (devariantize e ty1 x1, devariantize e ty2 x2)
+  | Rec t, _ -> devariantize (Econs (ty, e)) t v
+  | Pop t, _ -> (match e with Econs (_, e') -> devariantize e' t v)
+  | Var, _ -> (match e with Econs (t, e') -> devariantize e' t v)
+  | Conv (s, proj, inj, t), VConv (s', v) when s = s' ->
+      inj (devariantize e t v)
+  | Sum ops, VSum (tag, a) ->
+      begin try match List.assoc tag ops.sum_cases, a with
+      | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a)
+      | TCnoarg sel, None -> ops.sum_inj (sel, Noarg)
+      | _ -> raise VariantMismatch
+      with Not_found -> raise VariantMismatch
+      end
+  | _ -> raise VariantMismatch
+;;
+
+(* First attempt: represent 1-constructor variants using Conv *)
+let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);;
+
+let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;;
+let v = variantize Enil (ty Int);;
+let x = v (`A (Some (1, `A (Some (2, `A None))))) ;;
+
+(* Can also use it to decompose a tuple *)
+
+let triple t1 t2 t3 =
+  Conv ("Triple", (fun (a,b,c) -> (a,(b,c))),
+        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)))
+
+let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;;
+
+(* Second attempt: introduce a real sum construct *)
+let ty_abc =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  let proj = function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None
+  (* Define inj in advance to be able to write the type annotation easily *)
+  and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c ->
+    [`A of int | `B of string | `C] = function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  in
+  (* Coherence of sum_inj and sum_cases is checked by the typing *)
+  Sum { sum_proj = proj; sum_inj = inj; sum_cases =
+        [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+          "C", TCnoarg (Ttl (Ttl Thd)) ] }
+;;
+
+let v = variantize Enil ty_abc (`A 3)
+let a = devariantize Enil ty_abc v
+
+(* And an example with recursion... *)
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum {
+       sum_proj = (function
+           `Nil -> "Nil", None
+         | `Cons p -> "Cons", Some (Tdyn (tcons, p)));
+       sum_cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)];
+       sum_inj = fun (type c) ->
+         (function
+         | Thd, Noarg -> `Nil
+         | Ttl Thd, v -> `Cons v
+         : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)
+         (* One can also write the type annotation directly *)
+     })
+
+let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;;
+
+
+(* Simpler but weaker approach *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a)
+             -> ('a, 'e) ty
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+let ty_abc : ([`A of int | `B of string | `C],'e) ty =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  Sum (
+  (function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None),
+  (function
+      "A", Some (Tdyn (Int, n)) -> `A n
+    | "B", Some (Tdyn (String, s)) -> `B s
+    | "C", None -> `C
+    | _ -> invalid_arg "ty_abc"))
+;;
+
+(* Breaks: no way to pattern-match on a full recursive type *)
+let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
+  let targ = Pair (Pop t, Var) in
+  Rec (Sum (
+  (function `Nil -> "Nil", None
+    | `Cons p -> "Cons", Some (Tdyn (targ, p))),
+  (function "Nil", None -> `Nil
+    | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+;;
+
+(* Define Sum using object instead of record for first-class polymorphism *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: < proj: 'a -> string * 'e ty_dyn option;
+           cases: (string * ('e,'b) ty_case) list;
+           inj: 'c. ('b,'c) ty_sel * 'c -> 'a >
+          -> ('a, 'e) ty
+
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty =
+  Sum (object
+    method proj = function
+        `A n -> "A", Some (Tdyn (Int, n))
+      | `B s -> "B", Some (Tdyn (String, s))
+      | `C -> "C", None
+    method cases =
+      [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+        "C", TCnoarg (Ttl (Ttl Thd)) ];
+    method inj : type c.
+        (int -> string -> noarg -> unit, c) ty_sel * c ->
+          [`A of int | `B of string | `C] =
+      function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  end)
+
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum (object
+    method proj = function
+        `Nil -> "Nil", None
+      | `Cons p -> "Cons", Some (Tdyn (tcons, p))
+    method cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)]
+    method inj : type c.(noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist
+    = function
+      | Thd, Noarg -> `Nil
+      | Ttl Thd, v -> `Cons v
+  end))
+;;
+
+(*
+type (_,_) ty_assoc =
+  | Anil : (unit,'e) ty_assoc
+  | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc
+
+and (_,_) ty_pvar =
+  | Pnil : ('a,'e) ty_pvar
+  | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar
+  | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar
+*)
+(*
+   An attempt at encoding omega examples from the 2nd Central European
+   Functional Programming School:
+     Generic Programming in Omega, by Tim Sheard and Nathan Linger
+          http://web.cecs.pdx.edu/~sheard/
+*)
+
+(* Basic types *)
+
+type ('a,'b) sum = Inl of 'a | Inr of 'b
+
+type zero = Zero
+type 'a succ = Succ of 'a
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+;;
+
+(* 2: A simple example *)
+
+type (_,_) seq =
+  | Snil  : ('a,zero) seq
+  | Scons : 'a * ('a,'n) seq -> ('a, 'n succ) seq
+;;
+
+let l1 = Scons (3, Scons (5, Snil)) ;;
+
+(* We do not have type level functions, so we need to use witnesses. *)
+(* We copy here the definitions from section 3.9 *)
+(* Note the addition of the ['a nat] argument to PlusZ, since we do not
+   have kinds *)
+type (_,_,_) plus =
+  | PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a,'b,'c) plus -> ('a succ, 'b, 'c succ) plus
+;;
+
+let rec length : type a n. (a,n) seq -> n nat = function
+  | Snil -> NZ
+  | Scons (_, s) -> NS (length s)
+;;
+
+(* app returns the catenated lists with a witness proving that
+   the size is the sum of its two inputs *)
+type (_,_,_) app = App : ('a,'p) seq * ('n,'m,'p) plus -> ('a,'n,'m) app
+
+let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
+  fun xs ys ->
+  match xs with
+  | Snil -> App (ys, PlusZ (length ys))
+  | Scons (x, xs') ->
+      let App (xs'', pl) = app xs' ys in
+      App (Scons (x, xs''), PlusS pl)
+;;
+
+(* 3.1 Feature: kinds *)
+
+(* We do not have kinds, but we can encode them as predicates *)
+
+type tp = TP
+type nd = ND
+type ('a,'b) fk = FK
+type _ shape =
+  | Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a,'b) fk shape
+;;
+type tt = TT
+type ff = FF
+type _ boolean =
+  | BT : tt boolean
+  | BF : ff boolean
+;;
+
+(* 3.3 Feature : GADTs *)
+
+type (_,_) path =
+  | Pnone : 'a -> (tp,'a) path
+  | Phere : (nd,'a) path
+  | Pleft : ('x,'a) path -> (('x,'y) fk, 'a) path
+  | Pright : ('y,'a) path -> (('x,'y) fk, 'a) path
+;;
+type (_,_) tree =
+  | Ttip  : (tp,'a) tree
+  | Tnode : 'a -> (nd,'a) tree
+  | Tfork : ('x,'a) tree * ('y,'a) tree -> (('x,'y)fk, 'a) tree
+;;
+let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+;;
+let rec find : type sh.
+    ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list
+  = fun eq n t ->
+    match t with
+    | Ttip -> []
+    | Tnode m ->
+        if eq n m then [Phere] else []
+    | Tfork (x, y) ->
+        List.map (fun x -> Pleft x) (find eq n x) @
+        List.map (fun x -> Pright x) (find eq n y)
+;;
+let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
+  match (p, t) with
+  | Pnone x, Ttip -> x
+  | Phere, Tnode y -> y
+  | Pleft p, Tfork(l,_) -> extract p l
+  | Pright p, Tfork(_,r) -> extract p r
+;;
+
+(* 3.4 Pattern : Witness *)
+
+type (_,_) le =
+  | LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+;;
+type _ even =
+  | EvenZ : zero even
+  | EvenSS : 'n even -> 'n succ succ even
+;;
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+;;
+let even0 : zero even = EvenZ
+let even2 : two even = EvenSS EvenZ
+let even4 : four even = EvenSS (EvenSS EvenZ)
+;;
+let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+;;
+let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p ->
+  match p with
+  | PlusZ n -> LeZ n
+  | PlusS p' -> LeS (summandLessThanSum p')
+;;
+
+(* 3.8 Pattern: Leibniz Equality *)
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x
+
+let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
+  match a, b with
+  | NZ, NZ -> Some Eq
+  | NS a', NS b' ->
+      begin match sameNat a' b' with
+      | Some Eq -> Some Eq
+      | None -> None
+      end
+  | _ -> None
+;;
+
+(* Extra: associativity of addition *)
+
+let rec plus_func : type a b m n.
+  (a,b,m) plus -> (a,b,n) plus -> (m,n) equal =
+  fun p1 p2 ->
+  match p1, p2 with
+  | PlusZ _, PlusZ _ -> Eq
+  | PlusS p1', PlusS p2' ->
+      let Eq = plus_func p1' p2' in Eq
+
+let rec plus_assoc : type a b c ab bc m n.
+  (a,b,ab) plus -> (ab,c,m) plus ->
+  (b,c,bc) plus -> (a,bc,n) plus -> (m,n) equal = fun p1 p2 p3 p4 ->
+  match p1, p4 with
+  | PlusZ b, PlusZ bc ->
+      let Eq = plus_func p2 p3 in Eq
+  | PlusS p1', PlusS p4' ->
+      let PlusS p2' = p2 in
+      let Eq = plus_assoc p1' p2' p3 p4' in Eq
+;;
+
+(* 3.9 Computing Programs and Properties Simultaneously *)
+
+(* Plus and app1 are moved to section 2 *)
+
+let smaller : type a b. (a succ, b succ) le -> (a,b) le =
+  function LeS x -> x ;;
+
+type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;;
+
+(*
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b, le with
+  | NZ, m, _ -> Diff (m, PlusZ m)
+  | NS x, NZ, _ -> assert false
+  | NS x, NS y, q ->
+      match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+*)
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match le, a, b with
+  | LeZ _, _, m -> Diff (m, PlusZ m)
+  | LeS q, NS x, NS y ->
+      match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b,le with (* warning *)
+  | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+  | NS x, NS y, LeS q ->
+      (match diff q x y with Diff (m, p) -> Diff (m, PlusS p))
+  | _ -> .
+;;
+
+let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
+  fun le b ->
+  match b,le with
+  | m, LeZ _ -> Diff (m, PlusZ m)
+  | NS y, LeS q ->
+      match diff q y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter
+
+let rec leS' : type m n. (m,n) le -> (m,n succ) le = function
+  | LeZ n -> LeZ (NS n)
+  | LeS le -> LeS (leS' le)
+;;
+
+let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
+  fun f s ->
+  match s with
+  | Snil -> Filter (LeZ NZ, Snil)
+  | Scons (a,l) ->
+      match filter f l with Filter (le, l') ->
+        if f a then Filter (LeS le, Scons (a, l'))
+        else Filter (leS' le, l')
+;;
+
+(* 4.1 AVL trees *)
+
+type (_,_,_) balance =
+  | Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+
+type _ avl =
+  | Leaf : zero avl
+  | Node :
+      ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl
+
+type avl' = Avl : 'h avl -> avl'
+;;
+
+let empty = Avl Leaf
+
+let rec elem : type h. int -> h avl -> bool = fun x t ->
+  match t with
+  | Leaf -> false
+  | Node (_, l, y, r) ->
+      x = y || if x < y then elem x l else elem x r
+;;
+
+let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL y tR ->
+  match tL with
+  | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR)))
+  | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR)))
+  | Node (Less, a, x, Node (Same, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (Less, b, z, c)) ->
+      Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (More, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
+;;
+let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL u tR ->
+  match tR with
+  | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b))
+  | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b))
+  | Node (More, Node (Same, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (Less, a, x, b), y, c) ->
+      Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (More, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c)))
+;;
+let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
+  fun x t ->
+  match t with
+  | Leaf -> Inr (Node (Same, Leaf, x, Leaf))
+  | Node (bal, a, y, b) ->
+      if x = y then Inl t else
+      if x < y then begin
+        match ins x a with
+        | Inl a -> Inl (Node (bal, a, y, b))
+        | Inr a ->
+            match bal with
+            | Less -> Inl (Node (Same, a, y, b))
+            | Same -> Inr (Node (More, a, y, b))
+            | More -> rotr a y b
+      end else begin
+        match ins x b with
+        | Inl b -> Inl (Node (bal, a, y, b) : n avl)
+        | Inr b ->
+            match bal with
+            | More -> Inl (Node (Same, a, y, b) : n avl)
+            | Same -> Inr (Node (Less, a, y, b) : n succ avl)
+            | Less -> rotl a y b
+      end
+;;
+
+let insert x (Avl t) =
+  match ins x t with
+  | Inl t -> Avl t
+  | Inr t -> Avl t
+;;
+
+let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
+  function
+  | Node (Less, Leaf, x, r) -> (x, Inl r)
+  | Node (Same, Leaf, x, r) -> (x, Inl r)
+  | Node (bal, (Node _ as l) , x, r) ->
+      match del_min l with
+      | y, Inr l -> (y, Inr (Node (bal, l, x, r)))
+      | y, Inl l ->
+          (y, match bal with
+          | Same -> Inr (Node (Less, l, x, r))
+          | More -> Inl (Node (Same, l, x, r))
+          | Less -> rotl l x r)
+
+type _ avl_del =
+  | Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+
+let rec del : type n. int -> n avl -> n avl_del = fun y t ->
+  match t with
+  | Leaf -> Dsame Leaf
+  | Node (bal, l, x, r) ->
+      if x = y then begin
+        match r with
+        | Leaf ->
+            begin match bal with
+            | Same -> Ddecr (Eq, l)
+            | More -> Ddecr (Eq, l)
+            end
+        | Node _ ->
+            begin match bal, del_min r with
+            | _, (z, Inr r) -> Dsame (Node (bal, l, z, r))
+            | Same, (z, Inl r) -> Dsame (Node (More, l, z, r))
+            | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r))
+            | More, (z, Inl r) ->
+                match rotr l z r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else if y < x then begin
+        match del y l with
+        | Dsame l -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,l) ->
+            begin match bal with
+            | Same -> Dsame (Node (Less, l, x, r))
+            | More -> Ddecr (Eq, Node (Same, l, x, r))
+            | Less ->
+                match rotl l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else begin
+        match del y r with
+        | Dsame r -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,r) ->
+            begin match bal with
+            | Same -> Dsame (Node (More, l, x, r))
+            | Less -> Ddecr (Eq, Node (Same, l, x, r))
+            | More ->
+                match rotr l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end
+;;
+
+let delete x (Avl t) =
+  match del x t with
+  | Dsame t -> Avl t
+  | Ddecr (_, t) -> Avl t
+;;
+
+
+(* Exercise 22: Red-black trees *)
+
+type red = RED
+type black = BLACK
+type (_,_) sub_tree =
+  | Bleaf : (black, zero) sub_tree
+  | Rnode :
+      (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode :
+      ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+;;
+
+type dir = LeftD | RightD
+
+type (_,_) ctxt =
+  | CNil : (black,'n) ctxt
+  | CRed : int * dir * (black,'n) sub_tree * (red,'n) ctxt -> (black,'n) ctxt
+  | CBlk : int * dir * ('c1,'n) sub_tree * (black, 'n succ) ctxt -> ('c,'n) ctxt
+;;
+
+let blacken = function
+    Rnode (l, e, r) -> Bnode (l, e, r)
+
+type _ crep =
+  | Red : red crep
+  | Black : black crep
+
+let color : type c n. (c,n) sub_tree -> c crep = function
+  | Bleaf -> Black
+  | Rnode _ -> Red
+  | Bnode _ -> Black
+;;
+
+let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
+  fun ct t ->
+  match ct with
+  | CNil -> Root t
+  | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t))
+  | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle))
+  | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t))
+  | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle))
+;;
+let recolor d1 pE sib d2 gE uncle t =
+  match d1, d2 with
+  | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle)
+  | RightD, RightD -> Rnode (Bnode (t, pE, sib), gE, uncle)
+  | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t))
+  | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib))
+;;
+let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
+  match d1, d2 with
+  | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle))
+  | LeftD,  RightD -> Bnode (Rnode (sib, pE, x), e, Rnode (y, gE, uncle))
+  | LeftD,  LeftD  -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y))
+  | RightD, LeftD  -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib))
+;;
+let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun t ct ->
+  match ct with
+  | CNil -> Root (blacken t)
+  | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t))
+  | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib))
+  | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) ->
+      match color uncle with
+      | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct
+      | Black -> fill ct (rotate dir e sib dir' e' uncle t)
+;;
+let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun e t ct ->
+  match t with
+  | Rnode (l, e', r) ->
+      if e < e' then ins e l (CRed (e', RightD, r, ct))
+                else ins e r (CRed (e', LeftD, l, ct))
+  | Bnode (l, e', r) ->
+      if e < e' then ins e l (CBlk (e', RightD, r, ct))
+                else ins e r (CBlk (e', LeftD, l, ct))
+  | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct
+;;
+let insert e (Root t) = ins e t CNil
+;;
+
+(* 5.7 typed object languages using GADTs *)
+
+type _ term =
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let ex1 = Ap (Add, Pair (Const 3, Const 5))
+let ex2 = Pair (ex1, Const 1)
+
+let rec eval_term : type a. a term -> a = function
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x<y
+  | Ap(f,x) -> eval_term f (eval_term x)
+  | Pair(x,y) -> (eval_term x, eval_term y)
+
+type _ rep =
+  | Rint  : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun  : 'a rep * 'b rep -> ('a -> 'b) rep
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option =
+  fun ra rb ->
+  match ra, rb with
+  | Rint, Rint -> Some Eq
+  | Rbool, Rbool -> Some Eq
+  | Rpair (a1, a2), Rpair (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | Rfun (a1, a2), Rfun (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | _ -> None
+;;
+
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+
+let rec assoc : type a. string -> a rep -> assoc list -> a =
+  fun x r -> function
+  | [] -> raise Not_found
+  | Assoc (x', r', v) :: env ->
+      if x = x' then
+        match rep_equal r r' with
+        | None -> failwith ("Wrong type for " ^ x)
+        | Some Eq -> v
+      else assoc x r env
+
+type _ term =
+  | Var   : string * 'a rep -> 'a term
+  | Abs   : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let rec eval_term : type a. assoc list -> a term -> a =
+  fun env -> function
+  | Var (x, r) -> assoc x r env
+  | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x<y
+  | Ap(f,x) -> eval_term env f (eval_term env x)
+  | Pair(x,y) -> (eval_term env x, eval_term env y)
+;;
+
+let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint))))
+let ex4 = Ap (ex3, Const 3)
+
+let v4 = eval_term [] ex4
+;;
+
+(* 5.9/5.10 Language with binding *)
+
+type rnil = RNIL
+type ('a,'b,'c) rcons = RCons of 'a * 'b * 'c
+
+type _ is_row =
+  | Rnil  : rnil is_row
+  | Rcons : 'c is_row -> ('a,'b,'c) rcons is_row
+
+type (_,_) lam =
+  | Const : int -> ('e, int) lam
+  | Var : 'a -> (('a,'t,'e) rcons, 't) lam
+  | Shift : ('e,'t) lam -> (('a,'q,'e) rcons, 't) lam
+  | Abs : 'a * (('a,'s,'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+
+type x = X
+type y = Y
+
+let ex1 = App (Var X, Shift (Var Y))
+let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y)))
+;;
+
+type _ env =
+  | Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+
+let rec eval_lam : type e t. e env -> (e, t) lam -> t =
+  fun env m ->
+  match env, m with
+  | _, Const n -> n
+  | Econs (_, v, r), Var _ -> v
+  | Econs (_, _, r), Shift e -> eval_lam r e
+  | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body
+  | _, App (f, x)    -> eval_lam env f (eval_lam env x)
+;;
+
+type add = Add
+type suc = Suc
+
+let env0 = Econs (Zero, 0, Econs (Suc, succ, Econs (Add, (+), Enil)))
+
+let _0 : (_, int) lam = Var Zero
+let suc x = App (Shift (Var Suc : (_, int -> int) lam), x)
+let _1 = suc _0
+let _2 = suc _1
+let _3 = suc _2
+let add = Shift (Shift (Var Add : (_, int -> int -> int) lam))
+
+let double = Abs (X, App (App (Shift add, Var X), Var X))
+let ex3 = App (double, _3)
+;;
+
+let v3 = eval_lam env0 ex3
+;;
+
+(* 5.13: Constructing typing derivations at runtime *)
+
+(* Modified slightly to use the language of 5.10, since this is more fun.
+   Of course this works also with the language of 5.12. *)
+
+type _ rep =
+  | I : int rep
+  | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+
+let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum =
+  fun a b ->
+  match a, b with
+  | I, I -> Inr Eq
+  | Ar(x,y), Ar(s,t) ->
+      begin match compare x s with
+      | Inl _ as e -> e
+      | Inr Eq -> match compare y t with
+        | Inl _ as e -> e
+        | Inr Eq as e -> e
+      end
+  | I, Ar _ -> Inl "I <> Ar _"
+  | Ar _, I -> Inl "Ar _ <> I"
+;;
+
+type term =
+  | C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+
+type _ ctx =
+  | Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t,'x,'e) rcons ctx
+;;
+
+type _ checked =
+  | Cerror of string
+  | Cok : ('e,'t) lam * 't rep -> 'e checked
+
+let rec lookup : type e. string -> e ctx -> e checked =
+  fun name ctx ->
+  match ctx with
+  | Cnil -> Cerror ("Name not found: " ^ name)
+  | Ccons (l,s,t,rs) ->
+      if s = name then Cok (Var l,t) else
+      match lookup name rs with
+      | Cerror m -> Cerror m
+      | Cok (v, t) -> Cok (Shift v, t)
+;;
+
+let rec tc : type n e. n nat -> e ctx -> term -> e checked =
+  fun n ctx t ->
+  match t with
+  | V s -> lookup s ctx
+  | Ap(f,x) ->
+      begin match tc n ctx f with
+      | Cerror _ as e -> e
+      | Cok (f', ft) -> match tc n ctx x with
+        | Cerror _ as e -> e
+        | Cok (x', xt) ->
+            match ft with
+            | Ar (a, b) ->
+                begin match compare a xt with
+                | Inl s -> Cerror s
+                | Inr Eq -> Cok (App (f',x'), b)
+                end
+            | _ -> Cerror "Non fun in Ap"
+      end
+  | Ab(s,t,body) ->
+      begin match tc (NS n) (Ccons (n, s, t, ctx)) body with
+      | Cerror _ as e -> e
+      | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))
+      end
+  | C m -> Cok (Const m, I)
+;;
+
+let ctx0 =
+  Ccons (Zero, "0", I,
+         Ccons (Suc, "S", Ar(I,I),
+                Ccons (Add, "+", Ar(I,Ar(I,I)), Cnil)))
+
+let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));;
+let c1 = tc NZ ctx0 ex1;;
+let ex2 = Ap (ex1, C 3);;
+let c2 = tc NZ ctx0 ex2;;
+
+let eval_checked env = function
+  | Cerror s -> failwith s
+  | Cok (e, I) -> (eval_lam env e : int)
+  | Cok _ -> failwith "Can only evaluate expressions of type I"
+;;
+
+let v2 = eval_checked env0 c2 ;;
+
+(* 5.12 Soundness *)
+
+type pexp = PEXP
+type pval = PVAL
+type _ mode =
+  | Pexp : pexp mode
+  | Pval : pval mode
+
+type ('a,'b) tarr = TARR
+type tint = TINT
+
+type (_,_) rel =
+  | IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+
+type (_,_,_) lam =
+  | Const : ('a,'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a,'t,'e) rcons, 't) lam
+  | Shift : ('m,'e,'t) lam -> ('m, ('a,'q,'e) rcons, 't) lam
+  | Lam : 'a * ('m, ('a,'s,'e) rcons, 't) lam -> (pval, 'e, ('s,'t) tarr) lam
+  | App : ('m1, 'e, ('s,'t) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+;;
+
+let ex1 = App (Lam (X, Var X), Const (IntR, 3))
+
+let rec mode : type m e t. (m,e,t) lam -> m mode = function
+  | Lam (v, body) -> Pval
+  | Var v -> Pval
+  | Const (r, v) -> Pval
+  | Shift e -> mode e
+  | App _ -> Pexp
+;;
+
+type (_,_) sub =
+  | Id : ('r,'r) sub
+  | Bind : 't * ('m,'r2,'x) lam * ('r,'r2) sub -> (('t,'x,'r) rcons, 'r2) sub
+  | Push : ('r1,'r2) sub -> (('a,'b,'r1) rcons, ('a,'b,'r2) rcons) sub
+
+type (_,_) lam' = Ex : ('m, 's, 't) lam -> ('s,'t) lam'
+;;
+
+let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' =
+  fun t s ->
+  match t, s with
+  | _, Id -> Ex t
+  | Const(r,c), sub -> Ex (Const (r,c))
+  | Var v, Bind (x, e, r) -> Ex e
+  | Var v, Push sub -> Ex (Var v)
+  | Shift e, Bind (_, _, r) -> subst e r
+  | Shift e, Push sub ->
+      (match subst e sub with Ex a -> Ex (Shift a))
+  | App(f,x), sub ->
+      (match subst f sub, subst x sub with Ex g, Ex y -> Ex (App (g,y)))
+  | Lam(v,x), sub ->
+      (match subst x (Push sub) with Ex body -> Ex (Lam (v, body)))
+;;
+
+type closed = rnil
+
+type 'a rlam = ((pexp,closed,'a) lam, (pval,closed,'a) lam) sum ;;
+
+let rec rule : type a b.
+  (pval, closed, (a,b) tarr) lam -> (pval, closed, a) lam -> b rlam =
+  fun v1 v2 ->
+  match v1, v2 with
+  | Lam(x,body), v ->
+      begin
+        match subst body (Bind (x, v, Id)) with Ex term ->
+        match mode term with
+        | Pexp -> Inl term
+        | Pval -> Inr term
+      end
+  | Const (IntTo b, f), Const (IntR, x) ->
+      Inr (Const (b, f x))
+;;
+let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
+  | Lam (v, body) -> Inr (Lam (v, body))
+  | Const (r, v)  -> Inr (Const (r, v))
+  | App (e1, e2) ->
+      match mode e1, mode e2 with
+      | Pexp, _->
+          begin match onestep e1 with
+          | Inl e -> Inl(App(e,e2))
+          | Inr v -> Inl(App(v,e2))
+          end
+      | Pval, Pexp ->
+          begin match onestep e2 with
+          | Inl e -> Inl(App(e1,e))
+          | Inr v -> Inl(App(e1,v))
+          end
+      | Pval, Pval -> rule e1 e2
+;;
+type ('env, 'a) var =
+ | Zero : ('a * 'env, 'a) var
+ | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+;;
+type ('env, 'a) typ =
+ | Tint : ('env, int) typ
+ | Tbool : ('env, bool) typ
+ | Tvar : ('env, 'a) var -> ('env, 'a) typ
+;;
+let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
+ match ta, tb with
+   | Tint, Tint -> 0
+   | Tbool, Tbool -> 1
+   | Tvar var, tb -> 2
+   | _ -> .   (* error *)
+;;
+(* let x = f Tint (Tvar Zero) ;; *)
+type inkind = [ `Link | `Nonlink ]
+
+type _ inline_t =
+   | Text: string -> [< inkind > `Nonlink ] inline_t
+   | Bold: 'a inline_t list -> 'a inline_t
+   | Link: string -> [< inkind > `Link ] inline_t
+   | Mref: string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+;;
+
+let uppercase seq =
+   let rec process: type a. a inline_t -> a inline_t = function
+       | Text txt       -> Text (String.uppercase_ascii txt)
+       | Bold xs        -> Bold (List.map process xs)
+       | Link lnk       -> Link lnk
+       | Mref (lnk, xs) -> Mref (lnk, List.map process xs)
+   in List.map process seq
+;;
+
+type ast_t =
+   | Ast_Text of string
+   | Ast_Bold of ast_t list
+   | Ast_Link of string
+   | Ast_Mref of string * ast_t list
+;;
+
+let inlineseq_from_astseq seq =
+   let rec process_nonlink = function
+       | Ast_Text txt  -> Text txt
+       | Ast_Bold xs   -> Bold (List.map process_nonlink xs)
+       | _             -> assert false in
+   let rec process_any = function
+       | Ast_Text txt       -> Text txt
+       | Ast_Bold xs        -> Bold (List.map process_any xs)
+       | Ast_Link lnk       -> Link lnk
+       | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs)
+   in List.map process_any seq
+;;
+
+(* OK *)
+type _ linkp =
+ | Nonlink : [ `Nonlink ] linkp
+ | Maylink : inkind linkp
+;;
+let inlineseq_from_astseq seq =
+ let rec process : type a. a linkp -> ast_t -> a inline_t =
+   fun allow_link ast ->
+     match (allow_link, ast) with
+     | (Maylink, Ast_Text txt)    -> Text txt
+     | (Nonlink, Ast_Text txt)    -> Text txt
+     | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+     | (Maylink, Ast_Link lnk)    -> Link lnk
+     | (Nonlink, Ast_Link _)      -> assert false
+     | (Maylink, Ast_Mref (lnk, xs)) ->
+         Mref (lnk, List.map (process Nonlink) xs)
+     | (Nonlink, Ast_Mref _)      -> assert false
+   in List.map (process Maylink) seq
+;;
+
+(* Bad *)
+type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+;;
+let inlineseq_from_astseq seq =
+let rec process : type a. a linkp2 -> ast_t -> a inline_t =
+  fun allow_link ast ->
+    match (allow_link, ast) with
+    | (Kind _, Ast_Text txt)    -> Text txt
+    | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+    | (Kind Maylink, Ast_Link lnk)    -> Link lnk
+    | (Kind Nonlink, Ast_Link _)      -> assert false
+    | (Kind Maylink, Ast_Mref (lnk, xs)) ->
+        Mref (lnk, List.map (process (Kind Nonlink)) xs)
+    | (Kind Nonlink, Ast_Mref _)      -> assert false
+  in List.map (process (Kind Maylink)) seq
+;;
+module Add (T : sig type two end) =
+struct
+  type _ t =
+  | One : [`One] t
+  | Two : T.two t
+
+  let add (type a) : a t * a t -> string = function
+    | One, One -> "two"
+    | Two, Two -> "four"
+end;;
+module B : sig
+ type (_, _) t = Eq: ('a, 'a) t
+ val f: 'a -> 'b -> ('a, 'b) t
+end
+=
+struct
+ type (_, _) t = Eq: ('a, 'a) t
+ let f t1 t2 = Obj.magic Eq
+end;;
+
+let of_type: type a. a -> a = fun x ->
+  match B.f x 4 with
+  | Eq -> 5
+;;
+type _ constant =
+  | Int: int -> int constant
+  | Bool: bool -> bool constant
+
+type (_, _, _) binop =
+  | Eq: ('a, 'a, bool) binop
+  | Leq: ('a, 'a, bool) binop
+  | Add: (int, int, int) binop
+
+let eval (type a) (type b) (type c) (bop:(a,b,c) binop) (x:a constant)
+         (y:b constant) : c constant =
+  match bop, x, y with
+  | Eq, Bool x, Bool y -> Bool (if x then y else not y)
+  | Leq, Int x, Int y -> Bool (x <= y)
+  | Leq, Bool x, Bool y -> Bool (x <= y)
+  | Add, Int x, Int y -> Int (x + y)
+
+let _ = eval Eq (Int 2) (Int 3)
+type tag = [`TagA | `TagB | `TagC];;
+
+type 'a poly =
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int] poly
+(* constraint 'a = [< `TagA of int | `TagB] *)
+;;
+
+let intA = function `TagA i -> i
+let intB = function `TagB -> 4
+;;
+
+let intAorB = function
+    `TagA i -> i
+  | `TagB -> 4
+;;
+
+type _ wrapPoly =
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly
+;;
+
+let example6 : type a. a wrapPoly -> (a -> int) =
+  fun w  ->
+    match w with
+    | WrapPoly ATag -> intA
+    | WrapPoly _ -> intA (* This should not be allowed *)
+;;
+
+let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
+;;
+module F(S : sig type 'a t end) = struct
+  type _ ab =
+      A : int S.t ab
+    | B : float S.t ab
+
+  let f : int S.t ab -> float S.t ab -> string =
+    fun (l : int S.t ab) (r : float S.t ab) -> match l, r with
+    | A, B -> "f A B"
+end;;
+
+module F(S : sig type 'a t end) = struct
+  type a = int * int
+  type b = int -> int
+
+  type _ ab =
+      A : a S.t ab
+    | B : b S.t ab
+
+  let f : a S.t ab -> b S.t ab -> string =
+    fun l r -> match l, r with
+    | A, B -> "f A B"
+end;;
+type (_, _) t =
+    Any : ('a, 'b) t
+  | Eq : ('a, 'a) t
+;;
+
+module M :
+sig
+  type s = private [> `A]
+  val eq : (s, [`A | `B]) t
+end =
+struct
+  type s = [`A | `B]
+  let eq = Eq
+end;;
+
+let f : (M.s, [`A | `B]) t -> string = function
+  | Any -> "Any"
+;;
+
+let () = print_endline (f M.eq) ;;
+
+module N :
+sig
+  type s = private < a : int; .. >
+  val eq : (s, <a : int; b : bool>) t
+end =
+struct
+  type s = <a : int; b : bool>
+  let eq = Eq
+end
+;;
+
+let f : (N.s, <a : int; b : bool>) t -> string = function
+  | Any -> "Any"
+;;
+type (_, _) comp =
+  | Eq : ('a, 'a) comp
+  | Diff : ('a, 'b) comp
+;;
+
+module U = struct type t = T end;;
+
+module M : sig
+  type t = T
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+
+module U = struct type t = {x : int} end;;
+
+module M : sig
+  type t = {x : int}
+  val comp : (U.t, t) comp
+end = struct
+  include U
+  let comp = Eq
+end;;
+
+match M.comp with | Diff -> false;;
+type 'a t = T of 'a
+type 'a s = S of 'a
+
+type (_, _) eq = Refl : ('a, 'a) eq;;
+
+let f : (int s, int t) eq -> unit = function Refl -> ();;
+
+module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) =
+struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
+type _ nat =
+    Zero : [`Zero] nat
+  | Succ : 'a nat -> [`Succ of 'a] nat;;
+type 'a pre_nat = [`Zero | `Succ of 'a];;
+type aux =
+  | Aux : [`Succ of [<[<[<[`Zero] pre_nat] pre_nat] pre_nat]] nat -> aux;;
+
+let f (Aux x) =
+  match x with
+  | Succ Zero -> "1"
+  | Succ (Succ Zero) -> "2"
+  | Succ (Succ (Succ Zero)) -> "3"
+  | Succ (Succ (Succ (Succ Zero))) -> "4"
+  | _ -> .  (* error *)
+;;
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
+ fun C k -> k (fun x -> x);;
+type (_, _) t =
+ A : ('a, 'a) t
+| B : string -> ('a, 'b) t
+;;
+
+module M (A : sig module type T end) (B : sig module type T end) =
+struct
+ let f : ((module A.T), (module B.T)) t -> string = function
+   | B s -> s
+end;;
+
+module A = struct module type T = sig end end;;
+
+module N = M(A)(A);;
+
+let x = N.f A;;
+type 'a visit_action
+
+type insert
+
+type 'a local_visit_action
+
+type ('a, 'result, 'visit_action) context =
+  | Local : ('a, ('a * insert) as 'result, 'a local_visit_action) context
+  | Global : ('a, 'a, 'a visit_action) context
+;;
+
+let vexpr (type visit_action)
+    : (_, _, visit_action) context -> _ -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+
+let vexpr (type visit_action)
+    : ('a, 'result, visit_action) context -> 'a -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+
+let vexpr (type result) (type visit_action)
+    : (unit, result, visit_action) context -> unit -> visit_action =
+  function
+  | Local -> fun _ -> raise Exit
+  | Global -> fun _ -> raise Exit
+;;
+module A = struct
+    type nil = Cstr
+  end
+open A
+;;
+
+type _ s =
+  | Nil : nil s
+  | Cons : 't s -> ('h -> 't) s
+
+type ('stack, 'typ) var =
+  | Head : (('typ -> _) s, 'typ) var
+  | Tail : ('tail s, 'typ) var -> ((_ -> 'tail) s, 'typ) var
+
+type _ lst =
+  | CNil : nil lst
+  | CCons : 'h * ('t lst) -> ('h -> 't) lst
+;;
+
+let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s ->
+  match n, s with
+  | Head, CCons (h, _) -> h
+  | Tail n', CCons (_, t) -> get_var n' t
+;;
+type 'a t = [< `Foo | `Bar] as 'a;;
+type 'a s = [< `Foo | `Bar | `Baz > `Bar] as 'a;;
+
+type 'a first = First : 'a second -> ('b t as 'a) first
+and 'a second = Second : ('b s as 'a) second;;
+
+type aux = Aux : 'a t second * ('a -> int) -> aux;;
+
+let it : 'a. [< `Bar | `Foo > `Bar ] as 'a = `Bar;;
+
+let g (Aux(Second, f)) = f it;;
+type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
+let f : ('a list, 'a) eqp -> unit = function N s -> print_string s;;
+
+module rec A :  sig type t = B.t list end =
+  struct type t = B.t list end
+and B : sig  type t val eq : (B.t list, t) eqp end =
+  struct
+    type t = A.t
+    let eq = Y
+  end;;
+
+f B.eq;;
+type (_, _) t =
+  | Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t;;
+
+let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+
+let get1' = function
+  | (Cons (x, _) : (_ * 'a, 'a) t) -> x
+  | Nil -> assert false ;; (* ok *)
+type _ t =
+  Int : int -> int t | String : string -> string t | Same : 'l t -> 'l t;;
+let rec f = function Int x -> x | Same s -> f s;;
+type 'a tt = 'a t =
+  Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt;;
+type _ t = I : int t;;
+
+let f (type a) (x : a t) =
+  let module M = struct
+    let (I : a t) = x     (* fail because of toplevel let *)
+    let x = (I : a t)
+  end in
+  () ;;
+
+(* extra example by Stephen Dolan, using recursive modules *)
+(* Should not be allowed! *)
+type (_,_) eq = Refl : ('a, 'a) eq;;
+
+let bad (type a) =
+ let module N = struct
+   module rec M : sig
+     val e : (int, a) eq
+   end = struct
+     let (Refl : (int, a) eq) = M.e  (* must fail for soundness *)
+     let e : (int, a) eq = Refl
+   end
+ end in N.M.e
+;;
+type +'a n = private int
+type nil = private Nil_type
+type (_,_) elt =
+  | Elt_fine: 'nat n -> ('l,'nat * 'l) elt
+  | Elt: 'nat n -> ('l,'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t;;
+
+let undetected: ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j ->
+  let Cons(Elt dim, _) = sh in ()
+;;
+type _ t = T : int t;;
+
+(* Should raise Not_found *)
+let _ = match (raise Not_found : float t) with _ -> .;;
+type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq;;
+type 'a t;;
+let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
+
+module F (T : sig type _ t end) = struct
+ let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
+end;;
+(* First-Order Unification by Structural Recursion *)
+(* Conor McBride, JFP 13(6) *)
+(* http://strictlypositive.org/publications.html *)
+
+(* This is a translation of the code part to ocaml *)
+(* Of course, we do not prove other properties, not even termination *)
+
+(* 2.2 Inductive Families *)
+
+type zero = Zero
+type _ succ = Succ
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+
+type _ fin =
+  | FZ : 'a succ fin
+  | FS : 'a fin -> 'a succ fin
+
+(* We cannot define
+     val empty : zero fin -> 'a
+   because we cannot write an empty pattern matching.
+   This might be useful to have *)
+
+(* In place, prove that the parameter is 'a succ *)
+type _ is_succ = IS : 'a succ is_succ
+
+let fin_succ : type n. n fin -> n is_succ = function
+  | FZ -> IS
+  | FS _ -> IS
+;;
+
+(* 3 First-Order Terms, Renaming and Substitution *)
+
+type 'a term =
+  | Var of 'a fin
+  | Leaf
+  | Fork of 'a term * 'a term
+
+let var x = Var x
+
+let lift r : 'm fin -> 'n term = fun x -> Var (r x)
+
+let rec pre_subst f = function
+  | Var x -> f x
+  | Leaf -> Leaf
+  | Fork (t1, t2) -> Fork (pre_subst f t1, pre_subst f t2)
+
+let comp_subst f g (x : 'a fin) = pre_subst f (g x)
+(*  val comp_subst :
+    ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term *)
+;;
+
+(* 4 The Occur-Check, through thick and thin *)
+
+let rec thin : type n. n succ fin -> n fin -> n succ fin =
+  fun x y -> match x, y with
+  | FZ, y    -> FS y
+  | FS x, FZ -> FZ
+  | FS x, FS y -> FS (thin x y)
+
+let bind t f =
+  match t with
+  | None   -> None
+  | Some x -> f x
+(* val bind : 'a option -> ('a -> 'b option) -> 'b option *)
+
+let rec thick : type n. n succ fin -> n succ fin -> n fin option =
+  fun x y -> match x, y with
+  | FZ, FZ   -> None
+  | FZ, FS y -> Some y
+  | FS x, FZ -> let IS = fin_succ x in Some FZ
+  | FS x, FS y ->
+      let IS = fin_succ x in bind (thick x y) (fun x -> Some (FS x))
+
+let rec check : type n. n succ fin -> n succ term -> n term option =
+  fun x t -> match t with
+  | Var y -> bind (thick x y) (fun x -> Some (Var x))
+  | Leaf  -> Some Leaf
+  | Fork (t1, t2) ->
+      bind (check x t1) (fun t1 ->
+        bind (check x t2) (fun t2 -> Some (Fork (t1, t2))))
+
+let subst_var x t' y =
+  match thick x y with
+  | None -> t'
+  | Some y' -> Var y'
+(* val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term *)
+
+let subst x t' = pre_subst (subst_var x t')
+(* val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term *)
+;;
+
+(* 5 A Refinement of Substitution *)
+
+type (_,_) alist =
+  | Anil  : ('n,'n) alist
+  | Asnoc : ('m,'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
+
+let rec sub : type m n. (m,n) alist -> m fin -> n term = function
+  | Anil -> var
+  | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t)
+
+let rec append : type m n l. (m,n) alist -> (l,m) alist -> (l,n) alist =
+  fun r s -> match s with
+  | Anil -> r
+  | Asnoc (s, t, x) -> Asnoc (append r s, t, x)
+
+type _ ealist = EAlist : ('a,'b) alist -> 'a ealist
+
+let asnoc a t' x = EAlist (Asnoc (a, t', x))
+
+(* Extra work: we need sub to work on ealist too, for examples *)
+let rec weaken_fin : type n. n fin -> n succ fin = function
+  | FZ -> FZ
+  | FS x -> FS (weaken_fin x)
+
+let weaken_term t = pre_subst (fun x -> Var (weaken_fin x)) t
+
+let rec weaken_alist : type m n. (m, n) alist -> (m succ, n succ) alist =
+  function
+    | Anil -> Anil
+    | Asnoc (s, t, x) -> Asnoc (weaken_alist s, weaken_term t, weaken_fin x)
+
+let rec sub' : type m. m ealist -> m fin -> m term = function
+  | EAlist Anil -> var
+  | EAlist (Asnoc (s, t, x)) ->
+      comp_subst (sub' (EAlist (weaken_alist s)))
+        (fun t' -> weaken_term (subst_var x t t'))
+
+let subst' d = pre_subst (sub' d)
+(*  val subst' : 'a ealist -> 'a term -> 'a term *)
+;;
+
+(* 6 First-Order Unification *)
+
+let flex_flex x y =
+  match thick x y with
+  | Some y' -> asnoc Anil (Var y') x
+  | None -> EAlist Anil
+(* val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist *)
+
+let flex_rigid x t =
+  bind (check x t) (fun t' -> Some (asnoc Anil t' x))
+(* val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option *)
+
+let rec amgu : type m. m term -> m term -> m ealist -> m ealist option =
+  fun s t acc -> match s, t, acc with
+  | Leaf, Leaf, _   -> Some acc
+  | Leaf, Fork _, _ -> None
+  | Fork _, Leaf, _ -> None
+  | Fork (s1, s2), Fork (t1, t2), _ ->
+      bind (amgu s1 t1 acc) (amgu s2 t2)
+  | Var x, Var y, EAlist Anil -> let IS = fin_succ x in Some (flex_flex x y)
+  | Var x, t,     EAlist Anil -> let IS = fin_succ x in flex_rigid x t
+  | t, Var x,     EAlist Anil -> let IS = fin_succ x in flex_rigid x t
+  | s, t, EAlist(Asnoc(d,r,z)) ->
+      bind (amgu (subst z r s) (subst z r t) (EAlist d))
+           (fun (EAlist d) -> Some (asnoc d r z))
+
+let mgu s t = amgu s t (EAlist Anil)
+(* val mgu : 'a term -> 'a term -> 'a ealist option *)
+;;
+
+let s = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
+let t = Fork (Var (FS FZ), Var (FS FZ))
+let d = match mgu s t with Some x -> x | None -> failwith "mgu"
+let s' = subst' d s
+let t' = subst' d t
+;;
+(* Injectivity *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a b) (x : a) ->
+    let module M =
+      (functor (T : sig type 'a t end) ->
+       struct
+         let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+       end)
+        (struct type 'a t = unit end)
+    in M.f Refl
+;;
+
+(* Variance and subtyping *)
+
+type (_, +_) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a) (type b) (x : a) ->
+    let bad_proof (type a) =
+      (Refl : (< m : a>, <m : a>) eq :> (<m : a>, < >) eq) in
+    let downcast : type a. (a, < >) eq -> < > -> a =
+      fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in
+    (downcast bad_proof ((object method m = x end) :> < >)) # m
+;;
+
+(* Record patterns *)
+
+type _ t =
+  | IntLit : int t
+  | BoolLit : bool t
+
+let check : type s . s t * s -> bool = function
+  | BoolLit, false -> false
+  | IntLit , 6 -> false
+;;
+
+type ('a, 'b) pair = { fst : 'a; snd : 'b }
+
+let check : type s . (s t, s) pair -> bool = function
+  | {fst = BoolLit; snd = false} -> false
+  | {fst = IntLit ; snd =  6} -> false
+;;
+module type S = sig type t [@@immediate] end;;
+module F (M : S) : S = M;;
+[%%expect{|
+module type S = sig type t [@@immediate] end
+module F : functor (M : S) -> S
+|}];;
+
+(* VALID DECLARATIONS *)
+
+module A = struct
+  (* Abstract types can be immediate *)
+  type t [@@immediate]
+
+  (* [@@immediate] tag here is unnecessary but valid since t has it *)
+  type s = t [@@immediate]
+
+  (* Again, valid alias even without tag *)
+  type r = s
+
+  (* Mutually recursive declarations work as well *)
+  type p = q [@@immediate]
+  and q = int
+end;;
+[%%expect{|
+module A :
+  sig
+    type t [@@immediate]
+    type s = t [@@immediate]
+    type r = s
+    type p = q [@@immediate]
+    and q = int
+  end
+|}];;
+
+(* Valid using with constraints *)
+module type X = sig type t end;;
+module Y = struct type t = int end;;
+module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
+[%%expect{|
+module type X = sig type t end
+module Y : sig type t = int end
+module Z : sig type t [@@immediate] end
+|}];;
+
+(* Valid using an explicit signature *)
+module M_valid : S = struct type t = int end;;
+module FM_valid = F (struct type t = int end);;
+[%%expect{|
+module M_valid : S
+module FM_valid : S
+|}];;
+
+(* Practical usage over modules *)
+module Foo : sig type t val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+[%%expect{|
+module Foo : sig type t val x : t ref end
+|}];;
+
+module Bar : sig type t [@@immediate] val x : t ref end = struct
+  type t = int
+  let x = ref 0
+end;;
+[%%expect{|
+module Bar : sig type t [@@immediate] val x : t ref end
+|}];;
+
+let test f =
+  let start = Sys.time() in f ();
+  (Sys.time() -. start);;
+[%%expect{|
+val test : (unit -> 'a) -> float = <fun>
+|}];;
+
+let test_foo () =
+  for i = 0 to 100_000_000 do
+    Foo.x := !Foo.x
+  done;;
+[%%expect{|
+val test_foo : unit -> unit = <fun>
+|}];;
+
+let test_bar () =
+  for i = 0 to 100_000_000 do
+    Bar.x := !Bar.x
+  done;;
+[%%expect{|
+val test_bar : unit -> unit = <fun>
+|}];;
+
+(* Uncomment these to test. Should see substantial speedup!
+let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
+let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
+
+
+(* INVALID DECLARATIONS *)
+
+(* Cannot directly declare a non-immediate type as immediate *)
+module B = struct
+  type t = string [@@immediate]
+end;;
+[%%expect{|
+Line _, characters 2-31:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+
+(* Not guaranteed that t is immediate, so this is an invalid declaration *)
+module C = struct
+  type t
+  type s = t [@@immediate]
+end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+
+(* Can't ascribe to an immediate type signature with a non-immediate type *)
+module D : sig type t [@@immediate] end = struct
+  type t = string
+end;;
+[%%expect{|
+Line _, characters 42-70:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = string end
+       is not included in
+         sig type t [@@immediate] end
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
+
+(* Same as above but with explicit signature *)
+module M_invalid : S = struct type t = string end;;
+module FM_invalid = F (struct type t = string end);;
+[%%expect{|
+Line _, characters 23-49:
+Error: Signature mismatch:
+       Modules do not match: sig type t = string end is not included in S
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
+
+(* Can't use a non-immediate type even if mutually recursive *)
+module E = struct
+  type t = s [@@immediate]
+  and s = string
+end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
+(*
+   Implicit unpack allows to omit the signature in (val ...) expressions.
+
+   It also adds (module M : S) and (module M) patterns, relying on
+   implicit (val ...) for the implementation. Such patterns can only
+   be used in function definition, match clauses, and let ... in.
+
+   New: implicit pack is also supported, and you only need to be able
+   to infer the the module type path from the context.
+ *)
+(* ocaml -principal *)
+
+(* Use a module pattern *)
+let sort (type s) (module Set : Set.S with type elt = s) l =
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+(* No real improvement here? *)
+let make_set (type s) cmp : (module Set.S with type elt = s) =
+  (module Set.Make (struct type t = s let compare = cmp end))
+
+(* No type annotation here *)
+let sort_cmp (type s) cmp =
+  sort (module Set.Make (struct type t = s let compare = cmp end))
+
+module type S = sig type t val x : t end;;
+let f (module M : S with type t = int) = M.x;;
+let f (module M : S with type t = 'a) = M.x;; (* Error *)
+let f (type a) (module M : S with type t = a) = M.x;;
+f (module struct type t = int let x = 1 end);;
+
+type 'a s = {s: (module S with type t = 'a)};;
+{s=(module struct type t = int let x = 1 end)};;
+let f {s=(module M)} = M.x;; (* Error *)
+let f (type a) ({s=(module M)} : a s) = M.x;;
+
+type s = {s: (module S with type t = int)};;
+let f {s=(module M)} = M.x;;
+let f {s=(module M)} {s=(module N)} = M.x + N.x;;
+
+module type S = sig val x : int end;;
+let f (module M : S) y (module N : S) = M.x + y + N.x;;
+let m = (module struct let x = 3 end);; (* Error *)
+let m = (module struct let x = 3 end : S);;
+f m 1 m;;
+f m 1 (module struct let x = 2 end);;
+
+let (module M) = m in M.x;;
+let (module M) = m;; (* Error: only allowed in [let .. in] *)
+class c = let (module M) = m in object end;; (* Error again *)
+module M = (val m);;
+
+module type S' = sig val f : int -> int end;;
+(* Even works with recursion, but must be fully explicit *)
+let rec (module M : S') =
+  (module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S')
+in M.f 3;;
+
+(* Subtyping *)
+
+module type S = sig type t type u val x : t * u end
+let f (l : (module S with type t = int and type u = bool) list) =
+  (l :> (module S with type u = bool) list)
+
+(* GADTs from the manual *)
+(* the only modification is in to_string *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
+  let refl = (fun x -> x), (fun x -> x)
+  let apply (f, _) x = f x
+  let sym (f, g) = (g, f)
+end
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t and t1 and t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = Typ
+
+let int = Typ.Int TypEq.refl
+
+let str = Typ.String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  Typ.Pair (module P)
+
+open Typ
+let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
+  fun (type s) t x ->
+    match (t : s typ) with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair (module P) ->
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
+
+(* Wrapping maps *)
+module type MapT = sig
+  include Map.S
+  type data
+  type map
+  val of_t : data t -> map
+  val to_t : map -> data t
+end
+
+type ('k,'d,'m) map =
+    (module MapT with type key = 'k and type data = 'd and type map = 'm)
+
+let add (type k) (type d) (type m) (m:(k,d,m) map) x y s =
+   let module M =
+     (val m:MapT with type key = k and type data = d and type map = m) in
+   M.of_t (M.add x y (M.to_t s))
+
+module SSMap = struct
+  include Map.Make(String)
+  type data = string
+  type map = data t
+  let of_t x = x
+  let to_t x = x
+end
+
+let ssmap =
+  (module SSMap:
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (module struct include SSMap end :
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (let module S = struct include SSMap end in (module S) :
+  (module
+   MapT with type key = string and type data = string and type map = SSMap.map))
+;;
+
+let ssmap =
+  (module SSMap: MapT with type key = _ and type data = _ and type map = _)
+;;
+
+let ssmap : (_,_,_) map = (module SSMap);;
+
+add ssmap;;
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+let subst_var ~subst : var -> _ =
+  function `Var s as x ->
+    try Subst.find s subst
+    with Not_found -> x
+
+let free_var : var -> _ = function `Var s -> Names.singleton s
+
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let free_lambda ~free_rec : _ lambda -> _ = function
+    #var as x -> free_var x
+  | `Abs (s, t) -> Names.remove s (free_rec t)
+  | `App (t1, t2) -> Names.union (free_rec t1) (free_rec t2)
+
+let map_lambda ~map_rec : _ lambda -> _ = function
+    #var as x -> x
+  | `Abs (s, t) as l ->
+      let t' = map_rec t in
+      if t == t' then l else `Abs(s, t')
+  | `App (t1, t2) as l ->
+      let t'1 = map_rec t1 and t'2 = map_rec t2 in
+      if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _ = function
+    #var as x -> subst_var ~subst x
+  | `Abs(s, t) as l ->
+      let used = free t in
+      let used_expr =
+        Subst.fold subst ~init:[]
+          ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+      if List.exists used_expr ~f:(fun t -> Names.mem s (free t)) then
+        let name = s ^ string_of_int (next_id ()) in
+        `Abs(name,
+             subst_rec ~subst:(Subst.add ~key:s ~data:(`Var name) subst) t)
+      else
+        map_lambda ~map_rec:(subst_rec ~subst:(Subst.remove s subst)) l
+  | `App _ as l ->
+      map_lambda ~map_rec:(subst_rec ~subst) l
+
+let eval_lambda ~eval_rec ~subst l =
+  match map_lambda ~map_rec:eval_rec l with
+    `App(`Abs(s,t1), t2) ->
+      eval_rec (subst ~subst:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+  | t -> t
+
+(* Specialized versions to use on lambda *)
+
+let rec free1 x = free_lambda ~free_rec:free1 x
+let rec subst1 ~subst = subst_lambda ~subst_rec:subst1 ~free:free1 ~subst
+let rec eval1 x = eval_lambda ~eval_rec:eval1 ~subst:subst1 x
+
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [`Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+let free_expr ~free_rec : _ expr -> _ = function
+    #var as x -> free_var x
+  | `Num _ -> Names.empty
+  | `Add(x, y) -> Names.union (free_rec x) (free_rec y)
+  | `Neg x -> free_rec x
+  | `Mult(x, y) -> Names.union (free_rec x) (free_rec y)
+
+(* Here map_expr helps a lot *)
+let map_expr ~map_rec : _ expr -> _ = function
+    #var as x -> x
+  | `Num _ as x -> x
+  | `Add(x, y) as e ->
+      let x' = map_rec x and y' = map_rec y in
+      if x == x' && y == y' then e
+      else `Add(x', y')
+  | `Neg x as e ->
+      let x' = map_rec x in
+      if x == x' then e else `Neg x'
+  | `Mult(x, y) as e ->
+      let x' = map_rec x and y' = map_rec y in
+      if x == x' && y == y' then e
+      else `Mult(x', y')
+
+let subst_expr ~subst_rec ~subst : _ expr -> _ = function
+    #var as x -> subst_var ~subst x
+  | #expr as e -> map_expr ~map_rec:(subst_rec ~subst) e
+
+let eval_expr ~eval_rec e =
+  match map_expr ~map_rec:eval_rec e with
+    `Add(`Num m, `Num n) -> `Num (m+n)
+  | `Neg(`Num n) -> `Num (-n)
+  | `Mult(`Num m, `Num n) -> `Num (m*n)
+  | #expr as e -> e
+
+(* Specialized versions *)
+
+let rec free2 x = free_expr ~free_rec:free2 x
+let rec subst2 ~subst = subst_expr ~subst_rec:subst2 ~subst
+let rec eval2 x = eval_expr ~eval_rec:eval2 x
+
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type lexpr =
+  [ `Var of string | `Abs of string * lexpr | `App of lexpr * lexpr
+  | `Num of int | `Add of lexpr * lexpr | `Neg of lexpr
+  | `Mult of lexpr * lexpr ]
+
+let rec free : lexpr -> _ = function
+    #lambda as x -> free_lambda ~free_rec:free x
+  | #expr as x -> free_expr ~free_rec:free x
+
+let rec subst ~subst:s : lexpr -> _ = function
+    #lambda as x -> subst_lambda ~subst_rec:subst ~subst:s ~free x
+  | #expr as x -> subst_expr ~subst_rec:subst ~subst:s x
+
+let rec eval : lexpr -> _ = function
+    #lambda as x -> eval_lambda ~eval_rec:eval ~subst x
+  | #expr as x -> eval_expr ~eval_rec:eval x
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = eval1 (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = eval2 (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 = eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+(* Full fledge version, using objects to structure code *)
+
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+(* To build recursive objects *)
+
+let lazy_fix make =
+  let rec obj () = make (lazy (obj ()) : _ Lazy.t) in
+  obj ()
+
+let (!!) = Lazy.force
+
+(* The basic operations *)
+
+class type ['a, 'b] ops =
+  object
+    method free : x:'b -> ?y:'c -> Names.t
+    method subst : sub:'a Subst.t -> 'b -> 'a
+    method eval : 'b -> 'a
+  end
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+class ['a] var_ops = object (self : ('a, var) #ops)
+  constraint 'a = [> var]
+  method subst ~sub (`Var s as x) =
+    try Subst.find s sub with Not_found -> x
+  method free (`Var s) =
+    Names.singleton s
+  method eval (#var as v) = v
+end
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+class ['a] lambda_ops (ops : ('a,'a) #ops Lazy.t) =
+  let var : 'a var_ops = new var_ops
+  and free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ('a, 'a lambda) #ops)
+    constraint 'a = [> 'a lambda]
+    method free = function
+        #var as x -> var#free x
+      | `Abs (s, t) -> Names.remove s (!!free t)
+      | `App (t1, t2) -> Names.union (!!free t1) (!!free t2)
+
+    method map ~f = function
+        #var as x -> x
+      | `Abs (s, t) as l ->
+          let t' = f t in
+          if t == t' then l else `Abs(s, t')
+      | `App (t1, t2) as l ->
+          let t'1 = f t1 and t'2 = f t2 in
+          if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | `Abs(s, t) as l ->
+          let used = !!free t in
+          let used_expr =
+            Subst.fold sub ~init:[]
+              ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+          if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then
+            let name = s ^ string_of_int (next_id ()) in
+            `Abs(name,
+                 !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)
+          else
+            self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l
+      | `App _ as l ->
+          self#map ~f:(!!subst ~sub) l
+
+    method eval l =
+      match self#map ~f:!!eval l with
+        `App(`Abs(s,t1), t2) ->
+          !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+      | t -> t
+end
+
+(* Operations specialized to lambda *)
+
+let lambda = lazy_fix (new lambda_ops)
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [ `Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+class ['a] expr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let var : 'a var_ops = new var_ops
+  and free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ('a, 'a expr) #ops)
+    constraint 'a = [> 'a expr]
+    method free = function
+        #var as x -> var#free x
+      | `Num _ -> Names.empty
+      | `Add(x, y) -> Names.union (!!free x) (!!free y)
+      | `Neg x -> !!free x
+      | `Mult(x, y) -> Names.union (!!free x) (!!free y)
+
+    method map ~f = function
+        #var as x -> x
+      | `Num _ as x -> x
+      | `Add(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Add(x', y')
+      | `Neg x as e ->
+          let x' = f x in
+          if x == x' then e else `Neg x'
+      | `Mult(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Mult(x', y')
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | #expr as e -> self#map ~f:(!!subst ~sub) e
+
+    method eval (#expr as e) =
+      match self#map ~f:!!eval e with
+        `Add(`Num m, `Num n) -> `Num (m+n)
+      | `Neg(`Num n) -> `Num (-n)
+      | `Mult(`Num m, `Num n) -> `Num (m*n)
+      | e -> e
+  end
+
+(* Specialized versions *)
+
+let expr = lazy_fix (new expr_ops)
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type 'a lexpr = [ 'a lambda | 'a expr ]
+
+class ['a] lexpr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let lambda = new lambda_ops ops in
+  let expr = new expr_ops ops in
+  object (self : ('a, 'a lexpr) #ops)
+    constraint 'a = [> 'a lexpr]
+    method free = function
+        #lambda as x -> lambda#free x
+      | #expr as x -> expr#free x
+
+    method subst ~sub = function
+        #lambda as x -> lambda#subst ~sub x
+      | #expr as x -> expr#subst ~sub x
+
+    method eval = function
+        #lambda as x -> lambda#eval x
+      | #expr as x -> expr#eval x
+end
+
+let lexpr = lazy_fix (new lexpr_ops)
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 =
+    lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5))
+  in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+(* Full fledge version, using objects to structure code *)
+
+open StdLabels
+open MoreLabels
+
+(* Use maps for substitutions and sets for free variables *)
+
+module Subst = Map.Make(struct type t = string let compare = compare end)
+module Names = Set.Make(struct type t = string let compare = compare end)
+
+(* To build recursive objects *)
+
+let lazy_fix make =
+  let rec obj () = make (lazy (obj ()) : _ Lazy.t) in
+  obj ()
+
+let (!!) = Lazy.force
+
+(* The basic operations *)
+
+class type ['a, 'b] ops =
+  object
+    method free : 'b -> Names.t
+    method subst : sub:'a Subst.t -> 'b -> 'a
+    method eval : 'b -> 'a
+  end
+
+(* Variables are common to lambda and expr *)
+
+type var = [`Var of string]
+
+let var = object (self : ([>var], var) #ops)
+  method subst ~sub (`Var s as x) =
+    try Subst.find s sub with Not_found -> x
+  method free (`Var s) =
+    Names.singleton s
+  method eval (#var as v) = v
+end
+
+(* The lambda language: free variables, substitutions, and evaluation *)
+
+type 'a lambda = [`Var of string | `Abs of string * 'a | `App of 'a * 'a]
+
+let next_id =
+  let current = ref 3 in
+  fun () -> incr current; !current
+
+let lambda_ops (ops : ('a,'a) #ops Lazy.t) =
+  let free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ([> 'a lambda], 'a lambda) #ops)
+    method free = function
+        #var as x -> var#free x
+      | `Abs (s, t) -> Names.remove s (!!free t)
+      | `App (t1, t2) -> Names.union (!!free t1) (!!free t2)
+
+    method private map ~f = function
+        #var as x -> x
+      | `Abs (s, t) as l ->
+          let t' = f t in
+          if t == t' then l else `Abs(s, t')
+      | `App (t1, t2) as l ->
+          let t'1 = f t1 and t'2 = f t2 in
+          if t'1 == t1 && t'2 == t2 then l else `App (t'1, t'2)
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | `Abs(s, t) as l ->
+          let used = !!free t in
+          let used_expr =
+            Subst.fold sub ~init:[]
+              ~f:(fun ~key ~data acc ->
+                if Names.mem s used then data::acc else acc) in
+          if List.exists used_expr ~f:(fun t -> Names.mem s (!!free t)) then
+            let name = s ^ string_of_int (next_id ()) in
+            `Abs(name,
+                 !!subst ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)
+          else
+            self#map ~f:(!!subst ~sub:(Subst.remove s sub)) l
+      | `App _ as l ->
+          self#map ~f:(!!subst ~sub) l
+
+    method eval l =
+      match self#map ~f:!!eval l with
+        `App(`Abs(s,t1), t2) ->
+          !!eval (!!subst ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1)
+      | t -> t
+end
+
+(* Operations specialized to lambda *)
+
+let lambda = lazy_fix lambda_ops
+
+(* The expr language of arithmetic expressions *)
+
+type 'a expr =
+    [ `Var of string | `Num of int | `Add of 'a * 'a
+    | `Neg of 'a | `Mult of 'a * 'a]
+
+let expr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let free = lazy !!ops#free
+  and subst = lazy !!ops#subst
+  and eval = lazy !!ops#eval in
+  object (self : ([> 'a expr], 'a expr) #ops)
+    method free = function
+        #var as x -> var#free x
+      | `Num _ -> Names.empty
+      | `Add(x, y) -> Names.union (!!free x) (!!free y)
+      | `Neg x -> !!free x
+      | `Mult(x, y) -> Names.union (!!free x) (!!free y)
+
+    method private map ~f = function
+        #var as x -> x
+      | `Num _ as x -> x
+      | `Add(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Add(x', y')
+      | `Neg x as e ->
+          let x' = f x in
+          if x == x' then e else `Neg x'
+      | `Mult(x, y) as e ->
+          let x' = f x and y' = f y in
+          if x == x' && y == y' then e
+          else `Mult(x', y')
+
+    method subst ~sub = function
+        #var as x -> var#subst ~sub x
+      | #expr as e -> self#map ~f:(!!subst ~sub) e
+
+    method eval (#expr as e) =
+      match self#map ~f:!!eval e with
+        `Add(`Num m, `Num n) -> `Num (m+n)
+      | `Neg(`Num n) -> `Num (-n)
+      | `Mult(`Num m, `Num n) -> `Num (m*n)
+      | e -> e
+  end
+
+(* Specialized versions *)
+
+let expr = lazy_fix expr_ops
+
+(* The lexpr language, reunion of lambda and expr *)
+
+type 'a lexpr = [ 'a lambda | 'a expr ]
+
+let lexpr_ops (ops : ('a,'a) #ops Lazy.t) =
+  let lambda = lambda_ops ops in
+  let expr = expr_ops ops in
+  object (self : ([> 'a lexpr], 'a lexpr) #ops)
+    method free = function
+        #lambda as x -> lambda#free x
+      | #expr as x -> expr#free x
+
+    method subst ~sub = function
+        #lambda as x -> lambda#subst ~sub x
+      | #expr as x -> expr#subst ~sub x
+
+    method eval = function
+        #lambda as x -> lambda#eval x
+      | #expr as x -> expr#eval x
+end
+
+let lexpr = lazy_fix lexpr_ops
+
+let rec print = function
+  | `Var id -> print_string id
+  | `Abs (id, l) -> print_string ("\ " ^ id ^ " . "); print l
+  | `App (l1, l2) -> print l1; print_string " "; print l2
+  | `Num x -> print_int x
+  | `Add (e1, e2) -> print e1; print_string " + "; print e2
+  | `Neg e -> print_string "-"; print e
+  | `Mult (e1, e2) -> print e1; print_string " * "; print e2
+
+let () =
+  let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in
+  let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in
+  let e3 =
+    lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5))
+  in
+  print e1; print_newline ();
+  print e2; print_newline ();
+  print e3; print_newline ()
+type sexp = A of string | L of sexp list
+type 'a t = 'a array
+let _ = fun (_ : 'a t)  -> ()
+
+let array_of_sexp _ _ = [| |]
+let sexp_of_array _ _ = A "foo"
+let sexp_of_int _ = A "42"
+let int_of_sexp _ = 42
+
+let t_of_sexp : 'a . (sexp -> 'a) -> sexp -> 'a t=
+  let _tp_loc = "core_array.ml.t" in
+  fun _of_a  -> fun t  -> (array_of_sexp _of_a) t
+let _ = t_of_sexp
+let sexp_of_t : 'a . ('a -> sexp) -> 'a t -> sexp=
+  fun _of_a  -> fun v  -> (sexp_of_array _of_a) v
+let _ = sexp_of_t
+module T =
+  struct
+    module Int =
+      struct
+        type t_ = int array
+        let _ = fun (_ : t_)  -> ()
+
+        let t__of_sexp: sexp -> t_ =
+          let _tp_loc = "core_array.ml.T.Int.t_" in
+          fun t  -> (array_of_sexp int_of_sexp) t
+        let _ = t__of_sexp
+        let sexp_of_t_: t_ -> sexp =
+          fun v  -> (sexp_of_array sexp_of_int) v
+        let _ = sexp_of_t_
+      end
+  end
+module type Permissioned  =
+  sig
+    type ('a,-'perms) t
+  end
+module Permissioned :
+  sig
+    type ('a,-'perms) t
+    include
+      sig
+        val t_of_sexp :
+          (sexp -> 'a) ->
+            (sexp -> 'perms) -> sexp -> ('a,'perms) t
+        val sexp_of_t :
+          ('a -> sexp) ->
+            ('perms -> sexp) -> ('a,'perms) t -> sexp
+      end
+    module Int :
+    sig
+      type nonrec -'perms t = (int,'perms) t
+      include
+        sig
+          val t_of_sexp :
+            (sexp -> 'perms) -> sexp -> 'perms t
+          val sexp_of_t :
+            ('perms -> sexp) -> 'perms t -> sexp
+        end
+    end
+  end =
+  struct
+    type ('a,-'perms) t = 'a array
+    let _ = fun (_ : ('a,'perms) t)  -> ()
+
+    let t_of_sexp :
+      'a 'perms .
+        (sexp -> 'a) ->
+          (sexp -> 'perms) -> sexp -> ('a,'perms) t=
+      let _tp_loc = "core_array.ml.Permissioned.t" in
+      fun _of_a  -> fun _of_perms  -> fun t  -> (array_of_sexp _of_a) t
+    let _ = t_of_sexp
+    let sexp_of_t :
+      'a 'perms .
+        ('a -> sexp) ->
+          ('perms -> sexp) -> ('a,'perms) t -> sexp=
+      fun _of_a  -> fun _of_perms  -> fun v  -> (sexp_of_array _of_a) v
+    let _ = sexp_of_t
+    module Int =
+      struct
+        include T.Int
+        type -'perms t = t_
+        let _ = fun (_ : 'perms t)  -> ()
+
+        let t_of_sexp :
+          'perms . (sexp -> 'perms) -> sexp -> 'perms t=
+          let _tp_loc = "core_array.ml.Permissioned.Int.t" in
+          fun _of_perms  -> fun t  -> t__of_sexp t
+        let _ = t_of_sexp
+        let sexp_of_t :
+          'perms . ('perms -> sexp) -> 'perms t -> sexp=
+          fun _of_perms  -> fun v  -> sexp_of_t_ v
+        let _ = sexp_of_t
+      end
+  end
+type 'a  foo = {x: 'a; y: int}
+let r = {{x = 0; y = 0} with x = 0}
+let r' : string foo = r
+external foo : int = "%ignore";;
+let _ = foo ();;
+type 'a t = [`A of 'a t t] as 'a;; (* fails *)
+
+type 'a t = [`A of 'a t t];; (* fails *)
+
+type 'a t = [`A of 'a t t] constraint 'a = 'a t;;
+
+type 'a t = [`A of 'a t] constraint 'a = 'a t;;
+
+type 'a t = [`A of 'a] as 'a;;
+
+type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
+
+type 'a t = 'a;;
+let f (x : 'a t as 'a) = ();; (* fails *)
+
+let f (x : 'a t) (y : 'a) = x = y;;
+
+(* PR#6505 *)
+module type PR6505 = sig
+  type 'o is_an_object = < .. > as 'o
+  and 'o abs constraint 'o = 'o is_an_object
+  val abs : 'o is_an_object -> 'o abs
+  val unabs : 'o abs -> 'o
+end;; (* fails *)
+(* PR#5835 *)
+let f ~x = x + 1;;
+f ?x:0;;
+
+(* PR#6352 *)
+let foo (f : unit -> unit) = ();;
+let g ?x () = ();;
+foo ((); g);;
+
+(* PR#5748 *)
+foo (fun ?opt () -> ()) ;; (* fails *)
+(* PR#5907 *)
+
+type 'a t = 'a;;
+let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+type ab = [ `A | `B ];;
+let f (x : [`A]) = match x with #ab -> 1;;
+let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+
+let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+
+(* PR#6787 *)
+let revapply x f = f x;;
+
+let f x (g : [< `Foo]) =
+  let y = `Bar x, g in
+  revapply y (fun ((`Bar i), _) -> i);;
+(* f : 'a -> [< `Foo ] -> 'a *)
+
+let rec x = [| x |]; 1.;;
+
+let rec x = let u = [|y|] in 10. and y = 1.;;
+type 'a t
+type a
+
+let f : < .. > t -> unit = fun _ -> ();;
+
+let g : [< `b] t -> unit = fun _ -> ();;
+
+let h : [> `b] t -> unit = fun _ -> ();;
+
+let _ = fun (x : a t) -> f x;;
+
+let _ = fun (x : a t) -> g x;;
+
+let _ = fun (x : a t) -> h x;;
+(* PR#7012 *)
+
+type t = [ 'A_name | `Hi ];;
+
+let f (x:'id_arg) = x;;
+
+let f (x:'Id_arg) = x;;
+(* undefined labels *)
+type t = {x:int;y:int};;
+{x=3;z=2};;
+fun {x=3;z=2} -> ();;
+
+(* mixed labels *)
+{x=3; contents=2};;
+
+(* private types *)
+type u = private {mutable u:int};;
+{u=3};;
+fun x -> x.u <- 3;;
+
+(* Punning and abbreviations *)
+module M = struct
+  type t = {x: int; y: int}
+end;;
+
+let f {M.x; y} = x+y;;
+let r = {M.x=1; y=2};;
+let z = f r;;
+
+(* messages *)
+type foo = { mutable y:int };;
+let f (r: int) = r.y <- 3;;
+
+(* bugs *)
+type foo = { y: int; z: int };;
+type bar = { x: int };;
+let f (r: bar) = ({ r with z = 3 } : foo)
+
+type foo = { x: int };;
+let r : foo = { ZZZ.x = 2 };;
+
+(ZZZ.X : int option);;
+
+(* PR#5865 *)
+let f (x : Complex.t) = x.Complex.z;;
+(* PR#6394 *)
+
+module rec X : sig
+ type t = int * bool
+end = struct
+ type t = A | B
+ let f = function A | B -> 0
+end;;
+(* PR#6768 *)
+
+type _ prod = Prod : ('a * 'y) prod;;
+
+let f : type t. t prod -> _ = function Prod ->
+  let module M =
+    struct
+      type d = d * d
+    end
+  in ()
+;;
+let (a : M.a) = 2
+let (b : M.b) = 2
+let _ = A.a = B.b
+module Std = struct module Hash = Hashtbl end;;
+
+open Std;;
+module Hash1 : module type of Hash = Hash;;
+module Hash2 : sig include (module type of Hash) end = Hash;;
+let f1 (x : (_,_) Hash1.t) = (x : (_,_) Hashtbl.t);;
+let f2 (x : (_,_) Hash2.t) = (x : (_,_) Hashtbl.t);;
+
+(* Another case, not using include *)
+
+module Std2 = struct module M = struct type t end end;;
+module Std' = Std2;;
+module M' : module type of Std'.M = Std2.M;;
+let f3 (x : M'.t) = (x : Std2.M.t);;
+
+(* original report required Core_kernel:
+module type S = sig
+open Core_kernel.Std
+
+module Hashtbl1 : module type of Hashtbl
+module Hashtbl2 : sig
+  include (module type of Hashtbl)
+end
+
+module Coverage : Core_kernel.Std.Hashable
+
+type types = unit constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl1.t
+type doesnt_type = unit
+  constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl2.t
+end
+*)
+module type INCLUDING = sig
+  include module type of List
+  include module type of ListLabels
+end
+
+module Including_typed: INCLUDING = struct
+  include List
+  include ListLabels
+end
+module X=struct
+  module type SIG=sig type t=int val x:t end
+  module F(Y:SIG) : SIG = struct type t=Y.t let x=Y.x end
+end;;
+module DUMMY=struct type t=int let x=2 end;;
+let x = (3 : X.F(DUMMY).t);;
+
+module X2=struct
+  module type SIG=sig type t=int val x:t end
+  module F(Y:SIG)(Z:SIG) = struct
+    type t=Y.t
+    let x=Y.x
+    type t'=Z.t
+    let x'=Z.x
+  end
+end;;
+let x = (3 : X2.F(DUMMY)(DUMMY).t);;
+let x = (3 : X2.F(DUMMY)(DUMMY).t');;
+module F (M : sig
+    type 'a t
+    type 'a u = string
+    val f : unit -> _ u t
+  end) = struct
+    let t = M.f ()
+  end
+type 't a = [ `A ]
+type 't wrap = 't constraint 't = [> 't wrap a ]
+type t = t a wrap
+
+module T = struct
+  let foo : 't wrap -> 't wrap -> unit = fun _ _ -> ()
+  let bar : ('a a wrap as 'a) = `A
+end
+
+module Good : sig
+  val bar: t
+  val foo: t -> t -> unit
+end = T
+
+module Bad : sig
+  val foo: t -> t -> unit
+  val bar: t
+end = T
+module M : sig
+  module type T
+  module F (X : T) : sig end
+end = struct
+  module type T = sig end
+  module F (X : T) = struct end
+end
+
+module type T = M.T
+
+module F : functor (X : T) -> sig end = M.F
+module type S = sig type t = { a : int; b : int; } end;;
+let f (module M : S with type t = int) = { M.a = 0 };;
+let flag = ref false
+module F(S : sig module type T end) (A : S.T) (B : S.T) =
+struct
+  module X = (val if !flag then (module A) else (module B) : S.T)
+end
+
+(* If the above were accepted, one could break soundness *)
+module type S = sig type t val x : t end
+module Float = struct type t = float let x = 0.0 end
+module Int = struct type t = int let x = 0 end
+
+module M = F(struct module type T = S end)
+
+let () = flag := false
+module M1 = M(Float)(Int)
+
+let () = flag := true
+module M2 = M(Float)(Int)
+
+let _ = [| M2.X.x; M1.X.x |]
+module type PR6513 = sig
+module type S = sig type u end
+
+module type T = sig
+  type 'a wrap
+  type uri
+end
+
+module Make: functor (Html5 : T with type 'a wrap = 'a) ->
+  S with type u = < foo : Html5.uri >
+end
+
+(* Requires -package tyxml
+module type PR6513_orig = sig
+module type S =
+sig
+        type t
+        type u
+end
+
+module Make: functor (Html5: Html5_sigs.T
+                             with type 'a Xml.wrap = 'a and
+                             type 'a wrap = 'a and
+                             type 'a list_wrap = 'a list)
+                     -> S with type t = Html5_types.div Html5.elt and
+                               type u = < foo: Html5.uri >
+end
+*)
+module type S = sig
+  include Set.S
+  module E : sig val x : int end
+end
+
+module Make(O : Set.OrderedType) : S with type elt = O.t =
+  struct
+    include Set.Make(O)
+    module E = struct let x = 1 end
+  end
+
+module rec A : Set.OrderedType = struct
+ type t = int
+  let compare = Pervasives.compare
+end
+and B : S = struct
+ module C = Make(A)
+ include C
+end
+module type S = sig
+  module type T
+  module X : T
+end
+
+module F (X : S) = X.X
+
+module M = struct
+  module type T = sig type t end
+  module X = struct type t = int end
+end
+
+type t = F(M).t
+module Common0 =
+ struct
+   type msg = Msg
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+let q' : Common0.msg Queue.t = Common0.q
+
+module Common =
+ struct
+   type msg = ..
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+module M1 =
+ struct
+   type Common.msg += Reload of string | Alert of string
+
+   let handle fallback = function
+     Reload s -> print_endline ("Reload "^s)
+   | Alert s -> print_endline ("Alert "^s)
+   | x -> fallback x
+
+   let () = Common.extend_handle handle
+   let () = Common.add (Reload "config.file")
+   let () = Common.add (Alert "Initialisation done")
+ end
+let should_reject =
+  let table = Hashtbl.create 1 in
+  fun x y -> Hashtbl.add table x y
+type 'a t = 'a option
+let is_some = function
+  | None -> false
+  | Some _ -> true
+
+let should_accept ?x () = is_some x
+include struct
+  let foo `Test = ()
+  let wrap f `Test = f
+  let bar = wrap ()
+end
+let f () =
+   let module S = String in
+   let module N = Map.Make(S) in
+   N.add "sum" 41 N.empty;;
+module X = struct module Y = struct module type S = sig type t end end end
+
+(* open X  (* works! *) *)
+module Y = X.Y
+
+type 'a arg_t = 'at constraint 'a = (module Y.S with type t = 'at)
+type t = (module X.Y.S with type t = unit)
+
+let f (x : t arg_t) = ()
+
+let () = f ()
+module type S =
+sig
+  type a
+  type b
+end
+module Foo
+    (Bar : S with type a = private [> `A])
+    (Baz : S with type b = private < b : Bar.b ; .. >) =
+struct
+end
+module A = struct
+ module type A_S = sig
+ end
+
+ type t = (module A_S)
+end
+
+module type S = sig type t end
+
+let f (type a) (module X : S with type t = a) = ()
+
+let _ = f (module A) (* ok *)
+
+module A_annotated_alias : S with type t = (module A.A_S) = A
+
+let _ = f (module A_annotated_alias) (* ok *)
+let _ = f (module A_annotated_alias : S with type t = (module A.A_S)) (* ok *)
+
+module A_alias = A
+module A_alias_expanded = struct include A_alias end
+
+let _ = f (module A_alias_expanded : S with type t = (module A.A_S)) (* ok *)
+let _ = f (module A_alias_expanded) (* ok *)
+
+let _ = f (module A_alias : S with type t = (module A.A_S)) (* doesn't type *)
+let _ = f (module A_alias) (* doesn't type either *)
+module Foo
+ (Bar : sig type a = private [> `A ] end)
+ (Baz : module type of struct include Bar end) =
+struct
+end
+module Bazoinks = struct type a = [ `A ] end
+module Bug = Foo(Bazoinks)(Bazoinks)
+(* PR#6992, reported by Stephen Dolan *)
+
+type (_, _) eq = Eq : ('a, 'a) eq
+let cast : type a b . (a, b) eq -> a -> b = fun Eq x -> x
+
+module Fix (F : sig type 'a f end) = struct
+  type 'a fix = ('a, 'a F.f) eq
+  let uniq (type a) (type b) (Eq : a fix) (Eq : b fix) : (a, b) eq = Eq
+end
+
+(* This would allow:
+module FixId = Fix (struct type 'a f = 'a end)
+ let bad : (int, string) eq = FixId.uniq Eq Eq
+ let _ = Printf.printf "Oh dear: %s" (cast bad 42)
+*)
+module M = struct
+ module type S = sig type a val v : a end
+ type 'a s = (module S with type a = 'a)
+end
+
+module B = struct
+ class type a = object method a : 'a. 'a M.s -> 'a end
+end
+
+module M' = M
+module B' = B
+
+class b : B.a = object
+ method a : 'a. 'a M.s -> 'a = fun (type a) ((module X) : (module M.S with type
+a = a)) -> X.v
+end
+
+class b' : B.a = object
+ method a : 'a. 'a M'.s -> 'a = fun (type a) ((module X) : (module M'.S with
+type a = a)) -> X.v
+end
+module type FOO = sig type t end
+module type BAR =
+sig
+  (* Works: module rec A : (sig include FOO with type t = < b:B.t > end) *)
+  module rec A : (FOO with type t = < b:B.t >)
+         and B : FOO
+end
+module A = struct module type S module S = struct end end
+module F (_ : sig end) = struct module type S module S = A.S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : A.S = X
+module F (_ : sig end) = struct module type S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : F(M).S = X
+module M :  sig
+  type make_dec
+  val add_dec: make_dec -> unit
+end = struct
+  type u
+
+  module Fast: sig
+    type 'd t
+    val create: unit -> 'd t
+    module type S = sig
+      module Data: sig type t end
+      val key: Data.t t
+    end
+    module Register (D:S): sig end
+    val attach: 'd t -> 'd -> unit
+  end = struct
+    type 'd t = unit
+    let create () = ()
+    module type S = sig
+      module Data: sig type t end
+      val key: Data.t t
+    end
+    module Register (D:S) = struct end
+    let attach _ _ = ()
+  end
+
+  type make_dec
+
+  module Dem = struct
+    module Data = struct
+      type t = make_dec
+    end
+    let key = Fast.create ()
+  end
+
+  module EDem = Fast.Register(Dem)
+
+  let add_dec dec =
+    Fast.attach Dem.key dec
+end
+
+(* simpler version *)
+
+module Simple = struct
+  type 'a t
+  module type S = sig
+    module Data: sig type t end
+    val key: Data.t t
+  end
+  module Register (D:S) = struct let key = D.key end
+  module M = struct
+    module Data = struct type t = int end
+    let key : _ t = Obj.magic ()
+  end
+end;;
+module EM = Simple.Register(Simple.M);;
+Simple.M.key;;
+
+module Simple2 = struct
+  type 'a t
+  module type S = sig
+    module Data: sig type t end
+    val key: Data.t t
+  end
+  module M = struct
+    module Data = struct type t = int end
+    let key : _ t = Obj.magic ()
+  end
+  module Register (D:S) = struct let key = D.key end
+  module EM = Simple.Register(Simple.M)
+  let k : M.Data.t t = M.key
+end;;
+module rec M
+    : sig external f : int -> int = "%identity" end
+    = struct external f : int -> int = "%identity" end
+(* with module *)
+
+module type S = sig type t and s = t end;;
+module type S' = S with type t := int;;
+
+module type S = sig module rec M : sig end and N : sig end end;;
+module type S' = S with module M := String;;
+
+(* with module type *)
+(*
+module type S = sig module type T module F(X:T) : T end;;
+module type T0 = sig type t end;;
+module type S1 = S with module type T = T0;;
+module type S2 = S with module type T := T0;;
+module type S3 = S with module type T := sig type t = int end;;
+module H = struct
+  include (Hashtbl : module type of Hashtbl with
+           type statistics := Hashtbl.statistics
+           and module type S := Hashtbl.S
+           and module Make := Hashtbl.Make
+           and module MakeSeeded := Hashtbl.MakeSeeded
+           and module type SeededS := Hashtbl.SeededS
+           and module type HashedType := Hashtbl.HashedType
+           and module type SeededHashedType := Hashtbl.SeededHashedType)
+end;;
+*)
+
+(* A subtle problem appearing with -principal *)
+type -'a t
+class type c = object method m : [ `A ] t end;;
+module M : sig val v : (#c as 'a) -> 'a end =
+  struct let v x = ignore (x :> c); x end;;
+
+(* PR#4838 *)
+
+let id = let module M = struct end in fun x -> x;;
+
+(* PR#4511 *)
+
+let ko = let module M = struct end in fun _ -> ();;
+
+(* PR#5993 *)
+
+module M : sig type -'a t = private int end =
+  struct type +'a t = private int end
+;;
+
+(* PR#6005 *)
+
+module type A = sig type t = X of int end;;
+type u = X of bool;;
+module type B = A with type t = u;; (* fail *)
+
+(* PR#5815 *)
+(* ---> duplicated exception name is now an error *)
+
+module type S = sig exception Foo of int  exception Foo of bool end;;
+
+(* PR#6410 *)
+
+module F(X : sig end) = struct let x = 3 end;;
+F.x;; (* fail *)
+module C = Char;;
+C.chr 66;;
+
+module C' : module type of Char = C;;
+C'.chr 66;;
+
+module C3 = struct include Char end;;
+C3.chr 66;;
+
+let f x = let module M = struct module L = List end in M.L.length x;;
+let g x = let module L = List in L.length (L.map succ x);;
+
+module F(X:sig end) = Char;;
+module C4 = F(struct end);;
+C4.chr 66;;
+
+module G(X:sig end) = struct module M = X end;; (* does not alias X *)
+module M = G(struct end);;
+
+module M' = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+M'.N'.x;;
+
+module M'' : sig module N' : sig val x : int end end = M';;
+M''.N'.x;;
+module M2 = struct include M' end;;
+module M3 : sig module N' : sig val x : int end end = struct include M' end;;
+M3.N'.x;;
+module M3' : sig module N' : sig val x : int end end = M2;;
+M3'.N'.x;;
+
+module M4 : sig module N' : sig val x : int end end = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+M4.N'.x;;
+
+module F(X:sig end) = struct
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+module G : functor(X:sig end) -> sig module N' : sig val x : int end end = F;;
+module M5 = G(struct end);;
+M5.N'.x;;
+
+module M = struct
+  module D = struct let y = 3 end
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+
+module M1 : sig module N : sig val x : int end module N' = N end = M;;
+M1.N'.x;;
+module M2 : sig module N' : sig val x : int end end =
+  (M : sig module N : sig val x : int end module N' = N end);;
+M2.N'.x;;
+
+open M;;
+N'.x;;
+
+module M = struct
+  module C = Char
+  module C' = C
+end;;
+module M1
+  : sig module C : sig val escaped : char -> string end module C' = C end
+  = M;; (* sound, but should probably fail *)
+M1.C'.escaped 'A';;
+module M2 : sig module C' : sig val chr : int -> char end end =
+  (M : sig module C : sig val chr : int -> char end module C' = C end);;
+M2.C'.chr 66;;
+
+StdLabels.List.map;;
+
+module Q = Queue;;
+exception QE = Q.Empty;;
+try Q.pop (Q.create ()) with QE -> "Ok";;
+
+module type Complex = module type of Complex with type t = Complex.t;;
+module M : sig module C : Complex end = struct module C = Complex end;;
+
+module C = Complex;;
+C.one.Complex.re;;
+include C;;
+
+module F(X:sig module C = Char end) = struct module C = X.C end;;
+
+(* Applicative functors *)
+module S = String
+module StringSet = Set.Make(String)
+module SSet = Set.Make(S);;
+let f (x : StringSet.t) = (x : SSet.t);;
+
+(* Also using include (cf. Leo's mail 2013-11-16) *)
+module F (M : sig end) : sig type t end = struct type t = int end
+module T = struct
+  module M = struct end
+  include F(M)
+end;;
+include T;;
+let f (x : t) : T.t = x ;;
+
+(* PR#4049 *)
+(* This works thanks to abbreviations *)
+module A = struct
+  module B = struct type t let compare x y = 0 end
+  module S = Set.Make(B)
+  let empty = S.empty
+end
+module A1 = A;;
+A1.empty = A.empty;;
+
+(* PR#3476 *)
+(* Does not work yet *)
+module FF(X : sig end) = struct type t end
+module M = struct
+  module X = struct end
+  module Y = FF (X) (* XXX *)
+  type t = Y.t
+end
+module F (Y : sig type t end) (M : sig type t = Y.t end) = struct end;;
+
+module G = F (M.Y);;
+(*module N = G (M);;
+module N = F (M.Y) (M);;*)
+
+(* PR#6307 *)
+
+module A1 = struct end
+module A2 = struct end
+module L1 = struct module X = A1 end
+module L2 = struct module X = A2 end;;
+
+module F (L : (module type of L1)) = struct end;;
+
+module F1 = F(L1);; (* ok *)
+module F2 = F(L2);; (* should succeed too *)
+
+(* Counter example: why we need to be careful with PR#6307 *)
+module Int = struct type t = int let compare = compare end
+module SInt = Set.Make(Int)
+type (_,_) eq = Eq : ('a,'a) eq
+type wrap = W of (SInt.t, SInt.t) eq
+
+module M = struct
+  module I = Int
+  type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+end;;
+module type S = module type of M;; (* keep alias *)
+
+module Int2 = struct type t = int let compare x y = compare y x end;;
+module type S' = sig
+  module I = Int2
+  include S with module I := I
+end;; (* fail *)
+
+(* (* if the above succeeded, one could break invariants *)
+module rec M2 : S' = M2;; (* should succeed! (but this is bad) *)
+
+let M2.W eq = W Eq;;
+
+let s = List.fold_right SInt.add [1;2;3] SInt.empty;;
+module SInt2 = Set.Make(Int2);;
+let conv : type a b. (a,b) eq -> a -> b = fun Eq x -> x;;
+let s' : SInt2.t = conv eq s;;
+SInt2.elements s';;
+SInt2.mem 2 s';; (* invariants are broken *)
+*)
+
+(* Check behavior with submodules *)
+module M = struct
+  module N = struct module I = Int end
+  module P = struct module I = N.I end
+  module Q = struct
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq
+  end
+end;;
+module type S = module type of M ;;
+
+module M = struct
+  module N = struct module I = Int end
+  module P = struct module I = N.I end
+  module Q = struct
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq
+  end
+end;;
+module type S = module type of M ;;
+
+(* PR#6365 *)
+module type S = sig module M : sig type t val x : t end end;;
+module H = struct type t = A let x = A end;;
+module H' = H;;
+module type S' = S with module M = H';; (* shouldn't introduce an alias *)
+
+(* PR#6376 *)
+module type Alias = sig module N : sig end module M = N end;;
+module F (X : sig end) = struct type t end;;
+module type A = Alias with module N := F(List);;
+module rec Bad : A = Bad;;
+
+(* Shinwell 2014-04-23 *)
+module B = struct
+ module R = struct
+   type t = string
+ end
+
+ module O = R
+end
+
+module K = struct
+ module E = B
+ module N = E.O
+end;;
+
+let x : K.N.t = "foo";;
+
+(* PR#6465 *)
+
+module M = struct type t = A module B = struct type u = B end end;;
+module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *)
+module P : sig type t = M.t = A module B = M.B end = struct include M end;;
+
+module type S = sig
+  module M : sig module P : sig end end
+  module Q = M
+end;;
+module type S = sig
+  module M : sig module N : sig end module P : sig end end
+  module Q : sig module N = M.N module P = M.P end
+end;;
+module R = struct
+  module M = struct module N = struct end module P = struct end end
+  module Q = M
+end;;
+module R' : S = R;; (* should be ok *)
+
+(* PR#6578 *)
+
+module M = struct let f x = x end
+module rec R : sig module M : sig val f : 'a -> 'a end end =
+  struct module M = M end;;
+R.M.f 3;;
+module rec R : sig module M = M end = struct module M = M end;;
+R.M.f 3;;
+open A
+let f =
+  L.map S.capitalize
+
+let () =
+  L.iter print_endline (f ["jacques"; "garrigue"])
+
+module C : sig module L : module type of List end = struct include A end
+
+(* The following introduces a (useless) dependency on A:
+module C : sig module L : module type of List end = A
+*)
+
+include D'
+(*
+let () =
+  print_endline (string_of_int D'.M.y)
+*)
+open A
+let f =
+  L.map S.capitalize
+
+let () =
+  L.iter print_endline (f ["jacques"; "garrigue"])
+
+module C : sig module L : module type of List end = struct include A end
+
+(* The following introduces a (useless) dependency on A:
+module C : sig module L : module type of List end = A
+*)
+
+(* No dependency on D *)
+let x = 3
+module M = struct let y = 5 end
+module type S = sig type u type t end;;
+module type S' = sig type t = int type u = bool end;;
+
+(* ok to convert between structurally equal signatures, and parameters
+   are inferred *)
+let f (x : (module S with type t = 'a and type u = 'b)) = (x : (module S'));;
+let g x = (x : (module S with type t = 'a and type u = 'b) :> (module S'));;
+
+(* with subtyping it is also ok to forget some types *)
+module type S2 = sig type u type t type w end;;
+let g2 x = (x : (module S2 with type t = 'a and type u = 'b) :> (module S'));;
+let h x = (x : (module S2 with type t = 'a) :> (module S with type t = 'a));;
+let f2 (x : (module S2 with type t = 'a and type u = 'b)) =
+  (x : (module S'));; (* fail *)
+let k (x : (module S2 with type t = 'a)) =
+  (x : (module S with type t = 'a));; (* fail *)
+
+(* but you cannot forget values (no physical coercions) *)
+module type S3 = sig type u type t val x : int end;;
+let g3 x =
+  (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
+(* Using generative functors *)
+
+(* Without type *)
+module type S = sig val x : int end;;
+let v = (module struct let x = 3 end : S);;
+module F() = (val v);; (* ok *)
+module G (X : sig end) : S = F ();; (* ok *)
+module H (X : sig end) = (val v);; (* ok *)
+
+(* With type *)
+module type S = sig type t val x : t end;;
+let v = (module struct type t = int let x = 3 end : S);;
+module F() = (val v);; (* ok *)
+module G (X : sig end) : S = F ();; (* fail *)
+module H() = F();; (* ok *)
+
+(* Alias *)
+module U = struct end;;
+module M = F(struct end);; (* ok *)
+module M = F(U);; (* fail *)
+
+(* Cannot coerce between applicative and generative *)
+module F1 (X : sig end) = struct end;;
+module F2 : functor () -> sig end = F1;; (* fail *)
+module F3 () = struct end;;
+module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
+
+(* tests for shortened functor notation () *)
+module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;;
+module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) ->
+  struct end;;
+module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;;
+module GZ : functor (X: sig end) () (Z: sig end) -> sig end
+          = functor (X: sig end) () (Z: sig end) -> struct end;;
+module F (X : sig end) = struct type t = int end;;
+type t = F(Does_not_exist).t;;
+type expr =
+  [ `Abs of string * expr
+  | `App of expr * expr
+  ]
+
+class type exp =
+object
+  method eval : (string, exp) Hashtbl.t -> expr
+end;;
+
+class app e1 e2 : exp =
+object
+  val l = e1
+  val r = e2
+  method eval env =
+      match l with
+    | `Abs(var,body) ->
+        Hashtbl.add env var r;
+        body
+    | _ -> `App(l,r);
+end
+
+class virtual ['subject, 'event] observer =
+   object
+     method virtual notify : 'subject ->  'event -> unit
+   end
+
+class ['event] subject =
+   object (self : 'subject)
+     val mutable observers = ([]: (('subject, 'event) observer) list)
+     method add_observer obs = observers <- (obs :: observers)
+     method notify_observers (e : 'event) =
+         List.iter (fun x -> x#notify self e) observers
+   end
+
+type id = int
+
+class entity (id : id) =
+  object
+    val ent_destroy_subject = new subject
+    method destroy_subject : (id) subject = ent_destroy_subject
+
+    method entity_id = id
+  end
+
+class ['entity] entity_container =
+  object (self)
+    inherit ['entity, id] observer as observer
+
+    method add_entity (e : 'entity) =
+      e#destroy_subject#add_observer (self)
+
+    method notify _ id = ()
+  end
+
+let f (x : entity entity_container) = ()
+
+(*
+class world =
+  object
+    val entity_container : entity entity_container = new entity_container
+
+    method add_entity (s : entity) =
+      entity_container#add_entity (s :> entity)
+
+  end
+*)
+(* Two v's in the same class *)
+class c v = object initializer  print_endline v val v = 42 end;;
+new c "42";;
+
+(* Two hidden v's in the same class! *)
+class c (v : int) =
+  object
+    method v0 = v
+    inherit ((fun v -> object method v : string = v end) "42")
+  end;;
+(new c 42)#v0;;
+class virtual ['a] c =
+object (s : 'a)
+  method virtual m : 'b
+end
+
+let o =
+    object (s :'a)
+      inherit ['a] c
+      method m = 42
+    end
+module M :
+   sig
+     class x : int -> object method m : int end
+  end
+=
+struct
+  class x _ = object
+    method m = 42
+  end
+end;;
+module M : sig class c : 'a -> object val x : 'b end end =
+  struct class c x = object val x = x end end
+
+class c (x : int) = object inherit M.c x method x : bool = x end
+
+let r = (new c 2)#x;;
+(* test.ml *)
+class alfa = object(_:'self)
+  method x: 'a. ('a, out_channel, unit) format -> 'a = Printf.printf
+end
+
+class bravo a = object
+  val y = (a :> alfa)
+  initializer y#x "bravo initialized"
+end
+
+class charlie a = object
+  inherit bravo a
+  initializer y#x "charlie initialized"
+end
+(* The module begins *)
+exception Out_of_range
+
+class type ['a] cursor =
+  object
+    method get : 'a
+    method incr : unit -> unit
+    method is_last : bool
+  end
+
+class type ['a] storage =
+  object ('self)
+    method first : 'a cursor
+    method len : int
+    method nth : int -> 'a cursor
+    method copy : 'self
+    method sub : int -> int -> 'self
+    method concat : 'a storage -> 'self
+    method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b
+    method iter : ('a -> unit) -> unit
+  end
+
+class virtual ['a, 'cursor] storage_base =
+  object (self : 'self)
+    constraint 'cursor = 'a #cursor
+    method virtual first : 'cursor
+    method virtual len : int
+    method virtual copy : 'self
+    method virtual sub : int -> int -> 'self
+    method virtual concat : 'a storage -> 'self
+    method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 ->
+      let cur = self#first in
+      let rec loop count a =
+        if count >= self#len then a else
+        let a' = f cur#get count a in
+        cur#incr (); loop (count + 1) a'
+      in
+      loop 0 a0
+    method iter proc =
+      let p = self#first in
+      for i = 0 to self#len - 2 do proc p#get; p#incr () done;
+      if self#len > 0 then proc p#get else ()
+  end
+
+class type ['a] obj_input_channel =
+  object
+    method get : unit -> 'a
+    method close : unit -> unit
+  end
+
+class type ['a] obj_output_channel =
+  object
+    method put : 'a -> unit
+    method flush : unit -> unit
+    method close : unit -> unit
+  end
+
+module UChar =
+struct
+
+  type t = int
+
+  let highest_bit = 1 lsl 30
+  let lower_bits = highest_bit - 1
+
+  let char_of c =
+    try Char.chr c with Invalid_argument _ ->  raise Out_of_range
+
+  let of_char = Char.code
+
+  let code c =
+    if c lsr 30 = 0
+    then c
+    else raise Out_of_range
+
+  let chr n =
+    if n >= 0 && (n lsr 31 = 0) then n else raise Out_of_range
+
+  let uint_code c = c
+  let chr_of_uint n = n
+
+end
+
+type uchar = UChar.t
+
+let int_of_uchar u = UChar.uint_code u
+let uchar_of_int n = UChar.chr_of_uint n
+
+class type ucursor = [uchar] cursor
+
+class type ustorage = [uchar] storage
+
+class virtual ['ucursor] ustorage_base = [uchar, 'ucursor] storage_base
+
+module UText =
+struct
+
+(* the internal representation is UCS4 with big endian*)
+(* The most significant digit appears first. *)
+let get_buf s i =
+  let n = Char.code s.[i] in
+  let n = (n lsl 8) lor (Char.code s.[i + 1]) in
+  let n = (n lsl 8) lor (Char.code s.[i + 2]) in
+  let n = (n lsl 8) lor (Char.code s.[i + 3]) in
+  UChar.chr_of_uint n
+
+let set_buf s i u =
+  let n = UChar.uint_code u in
+  begin
+    s.[i] <- Char.chr (n lsr 24);
+    s.[i + 1] <- Char.chr (n lsr 16 lor 0xff);
+    s.[i + 2] <- Char.chr (n lsr 8 lor 0xff);
+    s.[i + 3] <- Char.chr (n lor 0xff);
+  end
+
+let init_buf buf pos init =
+  if init#len = 0 then () else
+  let cur = init#first in
+  for i = 0 to init#len - 2 do
+    set_buf buf (pos + i lsl 2) (cur#get); cur#incr ()
+  done;
+  set_buf buf (pos + (init#len - 1) lsl 2) (cur#get)
+
+let make_buf init =
+  let s = String.create (init#len lsl 2) in
+  init_buf s 0 init; s
+
+class text_raw buf =
+  object (self : 'self)
+    inherit [cursor] ustorage_base
+    val contents = buf
+    method first = new cursor (self :> text_raw) 0
+    method len = (String.length contents) / 4
+    method get i = get_buf contents (4 * i)
+    method nth i = new cursor (self :> text_raw) i
+    method copy = {< contents = String.copy contents >}
+    method sub pos len =
+      {< contents = String.sub contents (pos * 4) (len * 4) >}
+    method concat (text : ustorage) =
+      let buf = String.create (String.length contents + 4 * text#len) in
+      String.blit contents 0 buf 0 (String.length contents);
+      init_buf buf (String.length contents) text;
+      {< contents = buf >}
+  end
+and cursor text i =
+  object
+    val contents = text
+    val mutable pos = i
+    method get = contents#get pos
+    method incr () = pos <- pos + 1
+    method is_last = (pos + 1 >= contents#len)
+  end
+
+class string_raw buf =
+  object
+    inherit text_raw buf
+    method set i u = set_buf contents (4 * i) u
+  end
+
+class text init = text_raw (make_buf init)
+class string init = string_raw (make_buf init)
+
+let of_string s =
+  let buf = String.make (4 * String.length s) '\000' in
+  for i = 0 to String.length s - 1 do
+    buf.[4 * i] <- s.[i]
+  done;
+  new text_raw buf
+
+let make len u =
+  let s = String.create (4 * len) in
+  for i = 0 to len - 1 do set_buf s (4 * i) u done;
+  new string_raw s
+
+let create len = make len (UChar.chr 0)
+
+let copy s = s#copy
+
+let sub s start len = s#sub start len
+
+let fill s start len u =
+  for i = start to start + len - 1 do s#set i u done
+
+let blit src srcoff dst dstoff len =
+  for i = 0 to len - 1 do
+    let u = src#get (srcoff + i) in
+    dst#set (dstoff + i) u
+  done
+
+let concat s1 s2 = s1#concat (s2 (* : #ustorage *) :> uchar storage)
+
+let iter proc s = s#iter proc
+end
+class type foo_t =
+  object
+    method foo: string
+  end
+
+type 'a name =
+    Foo: foo_t name
+  | Int: int name
+;;
+
+class foo =
+  object(self)
+    method foo = "foo"
+    method cast =
+      function
+          Foo -> (self :> <foo : string>)
+  end
+;;
+
+class foo: foo_t =
+  object(self)
+    method foo = "foo"
+    method cast: type a. a name -> a =
+      function
+          Foo -> (self :> foo_t)
+        | _ -> raise Exit
+  end
+;;
+class type c = object end;;
+module type S = sig class c: c end;;
+class virtual name =
+object
+end
+
+and func (args_ty, ret_ty) =
+object(self)
+  inherit name
+
+  val mutable memo_args = None
+
+  method arguments =
+    match memo_args with
+    | Some xs -> xs
+    | None ->
+      let args = List.map (fun ty -> new argument(self, ty)) args_ty in
+        memo_args <- Some args; args
+end
+
+and argument (func, ty) =
+object
+  inherit name
+end
+;;
+let f (x: #M.foo) = 0;;
+class type ['e] t = object('s)
+  method update : 'e -> 's
+end;;
+
+module type S = sig
+  class base : 'e -> ['e] t
+end;;
+type 'par t = 'par
+module M : sig val x : <m : 'a. 'a> end =
+  struct let x : <m : 'a. 'a t> = Obj.magic () end
+
+let ident v = v
+class alias = object method alias : 'a . 'a t -> 'a = ident end
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object
+      constraint 'c = < m : 'a -> 'b -> int; .. >
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+type refer1 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+type refer2 = < poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) >
+
+(* Actually this should succeed ... *)
+let f (x : refer1) = (x : refer2)
+module Classdef = struct
+  class virtual ['a, 'b, 'c] cl0 =
+    object
+      constraint 'c = < m : 'a -> 'b -> int; .. >
+    end
+
+  class virtual ['a, 'b] cl1 =
+    object
+      method virtual raise_trouble : int -> 'a
+      method virtual m : 'a -> 'b -> int
+    end
+
+  class virtual ['a, 'b] cl2 =
+    object
+      method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0
+    end
+end
+
+module M : sig
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end = struct
+  type refer = { poly : 'a 'b 'c . (('b, 'c) #Classdef.cl2 as 'a) }
+end
+(*
+  ocamlc -c pr3918a.mli pr3918b.mli
+  rm -f pr3918a.cmi
+  ocamlc -c pr3918c.ml
+*)
+
+open Pr3918b
+
+let f x = (x : 'a vlist :> 'b vlist)
+let f (x : 'a vlist) = (x : 'b vlist)
+module type Poly = sig
+  type 'a t = 'a constraint 'a = [> ]
+end
+
+module Combine (A : Poly) (B : Poly) = struct
+  type ('a, 'b) t = 'a A.t constraint 'a = 'b B.t
+end
+
+module C = Combine
+  (struct type 'a t = 'a constraint 'a = [> ] end)
+  (struct type 'a t = 'a constraint 'a = [> ] end)
+module type Priv = sig
+  type t = private int
+end
+
+module Make (Unit:sig end): Priv = struct type t = int end
+
+module A = Make (struct end)
+
+module type Priv' = sig
+  type t = private [> `A]
+end
+
+module Make' (Unit:sig end): Priv' = struct type t = [`A] end
+
+module A' = Make' (struct end)
+(* PR5057 *)
+
+module TT = struct
+  module IntSet = Set.Make(struct type t = int let compare = compare end)
+end
+
+let () =
+  let f flag =
+    let module T = TT in
+    let _ = match flag with `A -> 0 | `B r -> r in
+    let _ = match flag with `A -> T.IntSet.mem | `B r -> r in
+    ()
+  in
+  f `A
+(* This one should fail *)
+
+let f flag =
+  let module T = Set.Make(struct type t = int let compare = compare end) in
+  let _ = match flag with `A -> 0 | `B r -> r in
+  let _ = match flag with `A -> T.mem | `B r -> r in
+  ()
+module type S = sig
+ type +'a t
+
+ val foo : [`A] t -> unit
+ val bar : [< `A | `B] t -> unit
+end
+
+module Make(T : S) = struct
+ let f x =
+   T.foo x;
+   T.bar x;
+   (x :> [`A | `C] T.t)
+end
+type 'a termpc =
+    [`And of 'a * 'a
+    |`Or of 'a * 'a
+    |`Not of 'a
+    |`Atom of string
+    ]
+
+type 'a termk =
+    [`Dia of 'a
+    |`Box of 'a
+    |'a termpc
+    ]
+
+module type T = sig
+  type term
+  val map : (term -> term) -> term -> term
+  val nnf : term -> term
+  val nnf_not : term -> term
+end
+
+module Fpc(X : T with type term = private [> 'a termpc] as 'a) =
+  struct
+    type term = X.term termpc
+    let nnf = function
+      |`Not(`Atom _) as x -> x
+      |`Not x     -> X.nnf_not x
+      | x         -> X.map X.nnf x
+    let map f : term -> X.term = function
+      |`Not x    -> `Not (f x)
+      |`And(x,y) -> `And (f x, f y)
+      |`Or (x,y) -> `Or  (f x, f y)
+      |`Atom _ as x -> x
+    let nnf_not : term -> _ = function
+      |`Not x    -> X.nnf x
+      |`And(x,y) -> `Or  (X.nnf_not x, X.nnf_not y)
+      |`Or (x,y) -> `And (X.nnf_not x, X.nnf_not y)
+      |`Atom _ as x -> `Not x
+  end
+
+module Fk(X : T with type term = private [> 'a termk] as 'a) =
+  struct
+    type term = X.term termk
+    module Pc = Fpc(X)
+    let map f : term -> _ = function
+      |`Dia x -> `Dia (f x)
+      |`Box x -> `Box (f x)
+      |#termpc as x -> Pc.map f x
+    let nnf = Pc.nnf
+    let nnf_not : term -> _ = function
+      |`Dia x -> `Box (X.nnf_not x)
+      |`Box x -> `Dia (X.nnf_not x)
+      |#termpc as x -> Pc.nnf_not x
+  end
+type untyped;;
+type -'a typed = private untyped;;
+type -'typing wrapped = private sexp
+and +'a t = 'a typed wrapped
+and sexp = private untyped wrapped;;
+class type ['a] s3 = object
+  val underlying : 'a t
+end;;
+class ['a] s3object r : ['a] s3 = object
+  val underlying = r
+end;;
+module M (T:sig type t end)
+ = struct type t = private { t : T.t } end
+module P
+ = struct
+       module T = struct type t end
+       module R = M(T)
+ end
+module Foobar : sig
+  type t = private int
+end = struct
+  type t = int
+end;;
+
+module F0 : sig type t = private int end = Foobar;;
+
+let f (x : F0.t) = (x : Foobar.t);; (* fails *)
+
+module F = Foobar;;
+
+let f (x : F.t) = (x : Foobar.t);;
+
+module M = struct type t = <m:int> end;;
+module M1 : sig type t = private <m:int; ..> end = M;;
+module M2 :  sig type t = private <m:int; ..> end = M1;;
+fun (x : M1.t) -> (x : M2.t);; (* fails *)
+
+module M3 : sig type t = private M1.t end = M1;;
+fun x -> (x : M3.t :> M1.t);;
+fun x -> (x : M3.t :> M.t);;
+module M4 : sig type t = private M3.t end = M2;; (* fails *)
+module M4 : sig type t = private M3.t end = M;; (* fails *)
+module M4 : sig type t = private M3.t end = M1;; (* might be ok *)
+module M5 : sig type t = private M1.t end = M3;;
+module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *)
+
+module Bar : sig type t = private Foobar.t val f : int -> t end =
+  struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
+
+module M : sig
+  type t = private T of int
+  val mk : int -> t
+end = struct
+  type t = T of int
+  let mk x = T(x)
+end;;
+
+module M1 : sig
+  type t = M.t
+  val mk : int -> t
+end = struct
+  type t = M.t
+  let mk = M.mk
+end;;
+
+module M2 : sig
+  type t = M.t
+  val mk : int -> t
+end = struct
+  include M
+end;;
+
+module M3 : sig
+  type t = M.t
+  val mk : int -> t
+end = M;;
+
+module M4 : sig
+    type t = M.t = T of int
+    val mk : int -> t
+  end = M;;
+(* Error: The variant or record definition does not match that of type M.t *)
+
+module M5 : sig
+  type t = M.t = private T of int
+  val mk : int -> t
+end = M;;
+
+module M6 : sig
+  type t = private T of int
+  val mk : int -> t
+end = M;;
+
+module M' : sig
+  type t_priv = private T of int
+  type t = t_priv
+  val mk : int -> t
+end = struct
+  type t_priv = T of int
+  type t = t_priv
+  let mk x = T(x)
+end;;
+
+module M3' : sig
+  type t = M'.t
+  val mk : int -> t
+end = M';;
+
+module M : sig type 'a t = private T of 'a end =
+  struct type 'a t = T of 'a end;;
+
+module M1 : sig type 'a t = 'a M.t = private T of 'a end =
+  struct type 'a t = 'a M.t = private T of 'a end;;
+
+(* PR#6090 *)
+module Test = struct type t = private A end
+module Test2 : module type of Test with type t = Test.t = Test;;
+let f (x : Test.t) = (x : Test2.t);;
+let f Test2.A = ();;
+let a = Test2.A;; (* fail *)
+(* The following should fail from a semantical point of view,
+   but allow it for backward compatibility *)
+module Test2 : module type of Test with type t = private Test.t = Test;;
+
+(* PR#6331 *)
+type t = private < x : int; .. > as 'a;;
+type t = private (< x : int; .. > as 'a) as 'a;;
+type t = private < x : int > as 'a;;
+type t = private (< x : int > as 'a) as 'b;;
+type 'a t = private < x : int; .. > as 'a;;
+type 'a t = private 'a constraint 'a = < x : int; .. >;;
+(* Bad (t = t) *)
+module rec A : sig type t = A.t end = struct type t = A.t end;;
+(* Bad (t = t) *)
+module rec A : sig type t = B.t end = struct type t = B.t end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* OK (t = int) *)
+module rec A : sig type t = B.t end = struct type t = B.t end
+       and B : sig type t = int end = struct type t = int end;;
+(* Bad (t = int * t) *)
+module rec A : sig type t = int * A.t end = struct type t = int * A.t end;;
+(* Bad (t = t -> int) *)
+module rec A : sig type t = B.t -> int end = struct type t = B.t -> int end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* OK (t = <m:t>) *)
+module rec A : sig type t = <m:B.t> end = struct type t = <m:B.t> end
+       and B : sig type t = A.t end = struct type t = A.t end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = <m: 'a list A.t> end
+             = struct type 'a t = <m: 'a list A.t> end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = <m: 'a list B.t; n: 'a array B.t> end
+             = struct type 'a t = <m: 'a list B.t; n: 'a array B.t> end
+       and B : sig type 'a t = 'a A.t end = struct type 'a t = 'a A.t end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = 'a B.t end
+             = struct type 'a t = 'a B.t end
+       and B : sig type 'a t = <m: 'a list A.t; n: 'a array A.t> end
+             = struct type 'a t = <m: 'a list A.t; n: 'a array A.t> end;;
+(* OK *)
+module rec A : sig type 'a t = 'a array B.t * 'a list B.t end
+             = struct type 'a t = 'a array B.t * 'a list B.t end
+       and B : sig type 'a t = <m: 'a B.t> end
+             = struct type 'a t = <m: 'a B.t> end;;
+(* Bad (not regular) *)
+module rec A : sig type 'a t = 'a list B.t end
+             = struct type 'a t = 'a list B.t end
+       and B : sig type 'a t = <m: 'a array B.t> end
+             = struct type 'a t = <m: 'a array B.t> end;;
+(* Bad (not regular) *)
+module rec M :
+    sig
+      class ['a] c : 'a -> object
+        method map : ('a -> 'b) -> 'b M.c
+      end
+    end
+  = struct
+      class ['a] c (x : 'a) = object
+        method map : 'b. ('a -> 'b) -> 'b M.c
+          = fun f -> new M.c (f x)
+      end
+    end;;
+(* OK *)
+class type [ 'node ] extension = object method node : 'node end
+and [ 'ext ] node = object constraint 'ext = 'ext node #extension [@id] end
+class x = object method node : x node = assert false end
+type t = x node;;
+(* Bad - PR 4261 *)
+
+module PR_4261 = struct
+  module type S =
+  sig
+    type t
+  end
+
+  module type T =
+  sig
+    module D : S
+    type t = D.t
+  end
+
+  module rec U : T with module D = U' = U
+  and U' : S with type t = U'.t = U
+end;;
+(* Bad - PR 4512 *)
+module type S' = sig type t = int end
+module rec M : S' with type t = M.t = struct type t = M.t end;;
+(* PR#4450 *)
+
+module PR_4450_1 = struct
+  module type MyT = sig type 'a t = Succ of 'a t end
+  module MyMap(X : MyT) = X
+  module rec MyList : MyT = MyMap(MyList)
+end;;
+
+module PR_4450_2 = struct
+  module type MyT = sig
+    type 'a wrap = My of 'a t
+    and 'a t = private < map : 'b. ('a -> 'b) ->'b wrap; .. >
+    val create : 'a list -> 'a t
+  end
+  module MyMap(X : MyT) = struct
+    include X
+    class ['a] c l = object (self)
+      method map : 'b. ('a -> 'b) -> 'b wrap =
+        fun f -> My (create (List.map f l))
+    end
+  end
+  module rec MyList : sig
+    type 'a wrap = My of 'a t
+    and 'a t = < map : 'b. ('a -> 'b) ->'b wrap >
+    val create : 'a list -> 'a t
+  end = struct
+    include MyMap(MyList)
+    let create l = new c l
+  end
+end;;
+(* A synthetic example of bootstrapped data structure
+   (suggested by J-C Filliatre) *)
+
+module type ORD = sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type SET = sig
+  type elt
+  type t
+  val iter : (elt -> unit) -> t -> unit
+end
+
+type 'a tree = E | N of 'a tree * 'a * 'a tree
+
+module Bootstrap2
+  (MakeDiet : functor (X: ORD) -> SET with type t = X.t tree and type elt = X.t)
+  : SET with type elt = int =
+struct
+
+  type elt = int
+
+  module rec Elt : sig
+    type t = I of int * int | D of int * Diet.t * int
+    val compare : t -> t -> int
+    val iter : (int -> unit) -> t -> unit
+  end =
+  struct
+    type t = I of int * int | D of int * Diet.t * int
+    let compare x1 x2 = 0
+    let rec iter f = function
+      | I (l, r) -> for i = l to r do f i done
+      | D (_, d, _) -> Diet.iter (iter f) d
+  end
+
+  and Diet : SET with type t = Elt.t tree and type elt = Elt.t = MakeDiet(Elt)
+
+  type t = Diet.t
+  let iter f = Diet.iter (Elt.iter f)
+end
+(* PR 4470: simplified from OMake's sources *)
+
+module rec DirElt
+  : sig
+      type t = DirRoot | DirSub of DirHash.t
+    end
+  = struct
+      type t = DirRoot | DirSub of DirHash.t
+    end
+
+and DirCompare
+  : sig
+      type t = DirElt.t
+    end
+  = struct
+      type t = DirElt.t
+    end
+
+and DirHash
+  : sig
+      type t = DirElt.t list
+    end
+  = struct
+      type t = DirCompare.t list
+    end
+(* PR 4758, PR 4266 *)
+
+module PR_4758 = struct
+  module type S = sig end
+  module type Mod = sig
+    module Other : S
+  end
+  module rec A : S = struct end
+  and C : sig include Mod with module Other = A end = struct
+    module Other = A
+  end
+  module C' = C  (* check that we can take an alias *)
+  module F(X:sig end) = struct type t end
+  let f (x : F(C).t) = (x : F(C').t)
+end
+(* PR 4557 *)
+module PR_4557 = struct
+  module F ( X : Set.OrderedType ) = struct
+    module rec Mod : sig
+      module XSet :
+        sig
+          type elt = X.t
+          type t = Set.Make( X ).t
+        end
+      module XMap :
+        sig
+          type key = X.t
+          type 'a t = 'a Map.Make(X).t
+        end
+      type elt = X.t
+      type t = XSet.t XMap.t
+      val compare: t -> t -> int
+    end
+       =
+    struct
+      module XSet = Set.Make( X )
+      module XMap = Map.Make( X )
+
+      type elt = X.t
+      type t = XSet.t XMap.t
+      let compare = (fun x y -> 0)
+    end
+    and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod )
+  end
+end
+module F ( X : Set.OrderedType ) = struct
+  module rec Mod : sig
+    module XSet :
+      sig
+        type elt = X.t
+        type t = Set.Make( X ).t
+      end
+    module XMap :
+      sig
+        type key = X.t
+        type 'a t = 'a Map.Make(X).t
+      end
+    type elt = X.t
+    type t = XSet.t XMap.t
+    val compare: t -> t -> int
+  end
+     =
+  struct
+    module XSet = Set.Make( X )
+    module XMap = Map.Make( X )
+
+    type elt = X.t
+    type t = XSet.t XMap.t
+    let compare = (fun x y -> 0)
+  end
+  and ModSet : Set.S with type elt = Mod.t = Set.Make( Mod )
+end
+(* Tests for recursive modules *)
+
+let test number result expected =
+  if result = expected
+  then Printf.printf "Test %d passed.\n" number
+  else Printf.printf "Test %d FAILED.\n" number;
+  flush stdout
+
+(* Tree of sets *)
+
+module rec A
+ : sig
+     type t = Leaf of int | Node of ASet.t
+     val compare: t -> t -> int
+   end
+ = struct
+     type t = Leaf of int | Node of ASet.t
+     let compare x y =
+       match (x,y) with
+         (Leaf i, Leaf j) -> Pervasives.compare i j
+       | (Leaf i, Node t) -> -1
+       | (Node s, Leaf j) -> 1
+       | (Node s, Node t) -> ASet.compare s t
+   end
+
+and ASet : Set.S with type elt = A.t = Set.Make(A)
+;;
+
+let _ =
+  let x = A.Node (ASet.add (A.Leaf 3) (ASet.singleton (A.Leaf 2))) in
+  let y = A.Node (ASet.add (A.Leaf 1) (ASet.singleton x)) in
+  test 10 (A.compare x x) 0;
+  test 11 (A.compare x (A.Leaf 3)) 1;
+  test 12 (A.compare (A.Leaf 0) x) (-1);
+  test 13 (A.compare y y) 0;
+  test 14 (A.compare x y) 1
+;;
+
+(* Simple value recursion *)
+
+module rec Fib
+  : sig val f : int -> int end
+  = struct let f x = if x < 2 then 1 else Fib.f(x-1) + Fib.f(x-2) end
+;;
+
+let _ =
+  test 20 (Fib.f 10) 89
+;;
+
+(* Update function by infix *)
+
+module rec Fib2
+  : sig val f : int -> int end
+  = struct let rec g x = Fib2.f(x-1) + Fib2.f(x-2)
+               and f x = if x < 2 then 1 else g x
+    end
+;;
+
+let _ =
+  test 21 (Fib2.f 10) 89
+;;
+
+(* Early application *)
+
+let _ =
+  let res =
+    try
+      let module A =
+        struct
+          module rec Bad
+            : sig val f : int -> int end
+            = struct let f = let y = Bad.f 5 in fun x -> x+y end
+          end in
+      false
+    with Undefined_recursive_module _ ->
+      true in
+  test 30 res true
+;;
+
+(* Early strict evaluation *)
+
+(*
+module rec Cyclic
+  : sig val x : int end
+  = struct let x = Cyclic.x + 1 end
+;;
+*)
+
+(* Reordering of evaluation based on dependencies *)
+
+module rec After
+  : sig val x : int end
+  = struct let x = Before.x + 1 end
+and Before
+  : sig val x : int end
+  = struct let x = 3 end
+;;
+
+let _ =
+  test 40 After.x 4
+;;
+
+(* Type identity between A.t and t within A's definition *)
+
+module rec Strengthen
+  : sig type t val f : t -> t end
+  = struct
+      type t = A | B
+      let _ = (A : Strengthen.t)
+      let f x = if true then A else Strengthen.f B
+    end
+;;
+
+module rec Strengthen2
+  : sig type t
+        val f : t -> t
+        module M : sig type u end
+        module R : sig type v end
+    end
+  = struct
+      type t = A | B
+      let _ = (A : Strengthen2.t)
+      let f x = if true then A else Strengthen2.f B
+      module M =
+        struct
+          type u = C
+          let _ = (C: Strengthen2.M.u)
+        end
+      module rec R : sig type v  = Strengthen2.R.v end =
+        struct
+          type v = D
+          let _ = (D : R.v)
+          let _ = (D : Strengthen2.R.v)
+        end
+    end
+;;
+
+(* Polymorphic recursion *)
+
+module rec PolyRec
+  : sig
+      type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+      val depth: 'a t -> int
+    end
+  = struct
+      type 'a t = Leaf of 'a | Node of 'a list t * 'a list t
+      let x = (PolyRec.Leaf 1 : int t)
+      let depth = function
+        Leaf x -> 0
+      | Node(l,r) -> 1 + max (PolyRec.depth l) (PolyRec.depth r)
+    end
+;;
+
+(* Wrong LHS signatures (PR#4336) *)
+
+(*
+module type ASig = sig type a val a:a val print:a -> unit end
+module type BSig = sig type b val b:b val print:b -> unit end
+
+module A = struct type a = int let a = 0 let print = print_int end
+module B = struct type b = float let b = 0.0 let print = print_float end
+
+module MakeA (Empty:sig end) : ASig = A
+module MakeB (Empty:sig end) : BSig = B
+
+module
+   rec NewA : ASig = MakeA (struct end)
+   and NewB : BSig with type b = NewA.a = MakeB (struct end);;
+
+*)
+
+(* Expressions and bindings *)
+
+module StringSet = Set.Make(String);;
+
+module rec Expr
+  : sig
+      type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+      val make_let: string -> t -> t -> t
+      val fv: t -> StringSet.t
+      val simpl: t -> t
+    end
+  = struct
+      type t =
+        Var of string
+      | Const of int
+      | Add of t * t
+      | Binding of Binding.t * t
+      let make_let id e1 e2 = Binding([id, e1], e2)
+      let rec fv = function
+        Var s -> StringSet.singleton s
+      | Const n -> StringSet.empty
+      | Add(t1,t2) -> StringSet.union (fv t1) (fv t2)
+      | Binding(b,t) ->
+          StringSet.union (Binding.fv b)
+            (StringSet.diff (fv t) (Binding.bv b))
+      let rec simpl = function
+        Var s -> Var s
+      | Const n -> Const n
+      | Add(Const i, Const j) -> Const (i+j)
+      | Add(Const 0, t) -> simpl t
+      | Add(t, Const 0) -> simpl t
+      | Add(t1,t2) -> Add(simpl t1, simpl t2)
+      | Binding(b, t) -> Binding(Binding.simpl b, simpl t)
+    end
+
+and Binding
+  : sig
+      type t = (string * Expr.t) list
+      val fv: t -> StringSet.t
+      val bv: t -> StringSet.t
+      val simpl: t -> t
+    end
+  = struct
+      type t = (string * Expr.t) list
+      let fv b =
+        List.fold_left (fun v (id,e) -> StringSet.union v (Expr.fv e))
+                       StringSet.empty b
+      let bv b =
+        List.fold_left (fun v (id,e) -> StringSet.add id v)
+                       StringSet.empty b
+      let simpl b =
+        List.map (fun (id,e) -> (id, Expr.simpl e)) b
+    end
+;;
+
+let _ =
+  let e = Expr.make_let "x" (Expr.Add (Expr.Var "y", Expr.Const 0))
+                            (Expr.Var "x") in
+  let e' = Expr.make_let "x" (Expr.Var "y") (Expr.Var "x") in
+  test 50 (StringSet.elements (Expr.fv e)) ["y"];
+  test 51 (Expr.simpl e) e'
+;;
+
+(* Okasaki's bootstrapping *)
+
+module type ORDERED =
+  sig
+    type t
+    val eq: t -> t -> bool
+    val lt: t -> t -> bool
+    val leq: t -> t -> bool
+  end
+
+module type HEAP =
+  sig
+    module Elem: ORDERED
+    type heap
+    val empty: heap
+    val isEmpty: heap -> bool
+    val insert: Elem.t -> heap -> heap
+    val merge: heap -> heap -> heap
+    val findMin: heap -> Elem.t
+    val deleteMin: heap -> heap
+  end
+
+module Bootstrap (MakeH: functor (Element:ORDERED) ->
+                                    HEAP with module Elem = Element)
+                 (Element: ORDERED) : HEAP with module Elem = Element =
+  struct
+    module Elem = Element
+    module rec BE
+    : sig type t = E | H of Elem.t * PrimH.heap
+          val eq: t -> t -> bool
+          val lt: t -> t -> bool
+          val leq: t -> t -> bool
+      end
+    = struct
+        type t = E | H of Elem.t * PrimH.heap
+        let leq t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.leq x y
+          | H _, E -> false
+          | E, H _ -> true
+          | E, E -> true
+        let eq t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.eq x y
+          | H _, E -> false
+          | E, H _ -> false
+          | E, E -> true
+        let lt t1 t2 =
+          match t1, t2 with
+          | (H(x, _)), (H(y, _)) -> Elem.lt x y
+          | H _, E -> false
+          | E, H _ -> true
+          | E, E -> false
+      end
+    and PrimH
+    : HEAP with type Elem.t = BE.t
+    = MakeH(BE)
+    type heap = BE.t
+    let empty = BE.E
+    let isEmpty = function BE.E -> true | _ -> false
+    let rec merge x y =
+      match (x,y) with
+        (BE.E, _) -> y
+      | (_, BE.E) -> x
+      | (BE.H(e1,p1) as h1), (BE.H(e2,p2) as h2) ->
+          if Elem.leq e1 e2
+          then BE.H(e1, PrimH.insert h2 p1)
+          else BE.H(e2, PrimH.insert h1 p2)
+    let insert x h =
+      merge (BE.H(x, PrimH.empty)) h
+    let findMin = function
+        BE.E -> raise Not_found
+      | BE.H(x, _) -> x
+    let deleteMin = function
+        BE.E -> raise Not_found
+      | BE.H(x, p) ->
+          if PrimH.isEmpty p then BE.E else begin
+            match PrimH.findMin p with
+            | (BE.H(y, p1)) ->
+              let p2 = PrimH.deleteMin p in
+              BE.H(y, PrimH.merge p1 p2)
+            | BE.E -> assert false
+          end
+  end
+;;
+
+module LeftistHeap(Element: ORDERED): HEAP with module Elem = Element =
+  struct
+    module Elem = Element
+    type heap = E | T of int * Elem.t * heap * heap
+    let rank = function E -> 0 | T(r,_,_,_) -> r
+    let make x a b =
+      if rank a >= rank b
+      then T(rank b + 1, x, a, b)
+      else T(rank a + 1, x, b, a)
+    let empty = E
+    let isEmpty = function E -> true | _ -> false
+    let rec merge h1 h2 =
+      match (h1, h2) with
+        (_, E) -> h1
+      | (E, _) -> h2
+      | (T(_, x1, a1, b1), T(_, x2, a2, b2)) ->
+          if Elem.leq x1 x2
+          then make x1 a1 (merge b1 h2)
+          else make x2 a2 (merge h1 b2)
+    let insert x h = merge (T(1, x, E, E)) h
+    let findMin = function
+      E -> raise Not_found
+    | T(_, x, _, _) -> x
+    let deleteMin = function
+      E -> raise Not_found
+    | T(_, x, a, b) -> merge a b
+  end
+;;
+
+module Ints =
+  struct
+    type t = int
+    let eq = (=)
+    let lt = (<)
+    let leq = (<=)
+  end
+;;
+
+module C = Bootstrap(LeftistHeap)(Ints);;
+
+let _ =
+  let h = List.fold_right C.insert [6;4;8;7;3;1] C.empty in
+  test 60 (C.findMin h) 1;
+  test 61 (C.findMin (C.deleteMin h)) 3;
+  test 62 (C.findMin (C.deleteMin (C.deleteMin h))) 4
+;;
+
+(* Classes *)
+
+module rec Class1
+  : sig
+      class c : object method m : int -> int end
+    end
+  = struct
+      class c =
+        object
+          method m x = if x <= 0 then x else (new Class2.d)#m x
+        end
+    end
+and Class2
+  : sig
+      class d : object method m : int -> int end
+    end
+  = struct
+      class d =
+        object(self)
+          inherit Class1.c as super
+          method m (x:int) = super#m 0
+        end
+    end
+;;
+
+let _ =
+  test 70 ((new Class1.c)#m 7) 0
+;;
+
+let _ =
+  try
+    let module A = struct
+       module rec BadClass1
+         : sig
+             class c : object method m : int end
+           end
+         = struct
+             class c = object method m = 123 end
+           end
+       and BadClass2
+         : sig
+             val x: int
+           end
+         = struct
+             let x = (new BadClass1.c)#m
+           end
+    end in
+      test 71 true false
+  with Undefined_recursive_module _ ->
+    test 71 true true
+;;
+
+(* Coercions *)
+
+module rec Coerce1
+  : sig
+      val g: int -> int
+      val f: int -> int
+    end
+  = struct
+      module A = (Coerce1: sig val f: int -> int end)
+      let g x = x
+      let f x = if x <= 0 then 1 else A.f (x-1) * x
+    end
+;;
+
+let _ =
+  test 80 (Coerce1.f 10) 3628800
+;;
+
+module CoerceF(S: sig end) = struct
+  let f1 () = 1
+  let f2 () = 2
+  let f3 () = 3
+  let f4 () = 4
+  let f5 () = 5
+end
+
+module rec Coerce2: sig val f1: unit -> int end = CoerceF(Coerce3)
+       and Coerce3: sig end = struct end
+;;
+
+let _ =
+  test 81 (Coerce2.f1 ()) 1
+;;
+
+module Coerce4(A : sig val f : int -> int end) = struct
+  let x = 0
+  let at a = A.f a
+end
+
+module rec Coerce5
+  : sig val blabla: int -> int val f: int -> int end
+  = struct let blabla x = 0 let f x = 5 end
+and Coerce6
+  : sig val at: int -> int end
+  = Coerce4(Coerce5)
+
+let _ =
+  test 82 (Coerce6.at 100) 5
+;;
+
+(* Miscellaneous bug reports *)
+
+module rec F
+  : sig type t = X of int | Y of int
+        val f: t -> bool
+    end
+  = struct
+      type t = X of int | Y of int
+      let f = function
+        | X _ -> false
+        | _ -> true
+    end;;
+
+let _ =
+  test 100 (F.f (F.X 1)) false;
+  test 101 (F.f (F.Y 2)) true
+
+(* PR#4316 *)
+module G(S : sig val x : int Lazy.t end) = struct include S end
+
+module M1 = struct let x = lazy 3 end
+
+let _ = Lazy.force M1.x
+
+module rec M2 : sig val x : int Lazy.t end = G(M1)
+
+let _ =
+  test 102 (Lazy.force M2.x) 3
+
+let _ = Gc.full_major()   (* will shortcut forwarding in M1.x *)
+
+module rec M3 : sig val x : int Lazy.t end = G(M1)
+
+let _ =
+  test 103 (Lazy.force M3.x) 3
+
+
+(** Pure type-checking tests: see recmod/*.ml  *)
+type t = A of {x:int; mutable y:int};;
+let f (A r) = r;;  (* -> escape *)
+let f (A r) = r.x;; (* ok *)
+let f x = A {x; y = x};; (* ok *)
+let f (A r) = A {r with y = r.x + 1};; (* ok *)
+let f () = A {a = 1};; (* customized error message *)
+let f () = A {x = 1; y = 3};; (* ok *)
+
+type _ t = A: {x : 'a; y : 'b} -> 'a t;;
+let f (A {x; y}) = A {x; y = ()};;  (* ok *)
+let f (A ({x; y} as r)) = A {x = r.x; y = r.y};; (* ok *)
+
+module M = struct
+  type 'a t =
+    | A of {x : 'a}
+    | B: {u : 'b} -> unit t;;
+
+  exception Foo of {x : int};;
+end;;
+
+module N : sig
+  type 'b t = 'b M.t =
+    | A of {x : 'b}
+    | B: {u : 'bla} -> unit t
+
+  exception Foo of {x : int}
+end = struct
+  type 'b t = 'b M.t =
+    | A of {x : 'b}
+    | B: {u : 'z} -> unit t
+
+  exception Foo = M.Foo
+end;;
+
+
+module type S = sig exception A of {x:int}  end;;
+
+module F (X : sig val x : (module S) end) = struct
+  module A = (val X.x)
+end;;  (* -> this expression creates fresh types (not really!) *)
+
+
+module type S = sig
+  exception A of {x : int}
+  exception A of {x : string}
+end;;
+
+module M = struct
+  exception A of {x : int}
+  exception A of {x : string}
+end;;
+
+
+module M1 = struct
+  exception A of {x : int}
+end;;
+
+module M = struct
+  include M1
+  include M1
+end;;
+
+
+module type S1 = sig
+  exception A of {x : int}
+end;;
+
+module type S = sig
+  include S1
+  include S1
+end;;
+
+module M = struct
+  exception A = M1.A
+end;;
+
+module X1 = struct
+  type t = ..
+end;;
+module X2 = struct
+  type t = ..
+end;;
+module Z = struct
+  type X1.t += A of {x: int}
+  type X2.t += A of {x: int}
+end;;
+
+(* PR#6716 *)
+
+type _ c = C : [`A] c
+type t = T : {x:[<`A] c} -> t;;
+let f (T { x = C }) = ();;
+module M : sig
+  type 'a t
+  type u = u t and v = v t
+  val f : int -> u
+  val g : v -> bool
+end = struct
+  type 'a t = 'a
+  type u = int and v = bool
+  let f x = x
+  let g x = x
+end;;
+
+let h (x : int) : bool = M.g (M.f x);;
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
+ fun C k -> k (fun x -> x);;
+module type T = sig type 'a t end
+module Fix (T : T) = struct type r = ('r T.t as 'r) end
+ type _ t =
+     X of string
+   | Y : bytes t
+
+let y : string t = Y
+let f : string A.t -> unit = function
+    A.X s -> print_endline s
+
+let () = f A.y
+module rec A : sig
+ type t
+end = struct
+ type t = { a : unit; b : unit }
+ let _ = { a = () }
+end
+;;
+type t = [`A | `B];;
+type 'a u = t;;
+let a : [< int u] = `A;;
+
+type 'a s = 'a;;
+let b : [< t s] = `B;;
+module Core = struct
+  module Int = struct
+    module T = struct
+      type t = int
+      let compare = compare
+      let (+) x y = x + y
+    end
+    include T
+    module Map = Map.Make(T)
+  end
+
+  module Std = struct
+    module Int = Int
+  end
+end
+;;
+
+open Core.Std
+;;
+
+let x = Int.Map.empty ;;
+let y = x + x ;;
+
+(* Avoid ambiguity *)
+
+module M = struct type t = A type u = C end
+module N = struct type t = B end
+open M open N;;
+A;;
+B;;
+C;;
+
+include M open M;;
+C;;
+
+module L = struct type v = V end
+open L;;
+V;;
+module L = struct type v = V end
+open L;;
+V;;
+
+
+type t1 = A;;
+module M1 = struct type u = v and v = t1 end;;
+module N1 = struct type u = v and v = M1.v end;;
+type t1 = B;;
+module N2 = struct type u = v and v = M1.v end;;
+
+
+(* PR#6566 *)
+module type PR6566 = sig type t = string end;;
+module PR6566 = struct type t = int end;;
+module PR6566' : PR6566 = PR6566;;
+
+module A = struct module B = struct type t = T end end;;
+module M2 = struct type u = A.B.t type foo = int type v = A.B.t end;;
+(* Adapted from: An Expressive Language of Signatures
+   by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
+
+module type VALUE = sig
+  type value (* a Lua value *)
+  type state (* the state of a Lua interpreter *)
+  type usert (* a user-defined value *)
+end;;
+
+module type CORE0 = sig
+  module V : VALUE
+  val setglobal : V.state -> string -> V.value -> unit
+  (* five more functions common to core and evaluator *)
+end;;
+
+module type CORE = sig
+  include CORE0
+  val apply : V.value -> V.state -> V.value list -> V.value
+  (* apply function f in state s to list of args *)
+end;;
+
+module type AST = sig
+  module Value : VALUE
+  type chunk
+  type program
+  val get_value : chunk -> Value.value
+end;;
+
+module type EVALUATOR = sig
+  module Value : VALUE
+  module Ast : (AST with module Value := Value)
+  type state = Value.state
+  type value = Value.value
+  exception Error of string
+  val compile : Ast.program -> string
+  include CORE0 with module V := Value
+end;;
+
+module type PARSER = sig
+  type chunk
+  val parse : string -> chunk
+end;;
+
+module type INTERP = sig
+  include EVALUATOR
+  module Parser : PARSER with type chunk = Ast.chunk
+  val dostring : state -> string -> value list
+  val mk : unit -> state
+end;;
+
+module type USERTYPE = sig
+  type t
+  val eq : t -> t -> bool
+  val to_string : t -> string
+end;;
+
+module type TYPEVIEW = sig
+  type combined
+  type t
+  val map : (combined -> t) * (t -> combined)
+end;;
+
+module type COMBINED_COMMON = sig
+  module T : sig type t end
+  module TV1 : TYPEVIEW with type combined := T.t
+  module TV2 : TYPEVIEW with type combined := T.t
+end;;
+
+module type COMBINED_TYPE = sig
+  module T : USERTYPE
+  include COMBINED_COMMON with module T := T
+end;;
+
+module type BARECODE = sig
+  type state
+  val init : state -> unit
+end;;
+
+module USERCODE(X : TYPEVIEW) = struct
+  module type F =
+      functor (C : CORE with type V.usert = X.combined) ->
+        BARECODE with type state := C.V.state
+end;;
+
+module Weapon = struct type t end;;
+
+module type WEAPON_LIB = sig
+  type t = Weapon.t
+  module T : USERTYPE with type t = t
+  module Make :
+    functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F
+end;;
+
+module type X = functor (X: CORE) -> BARECODE;;
+module type X = functor (_: CORE) -> BARECODE;;
+module M = struct
+  type t = int * (< m : 'a > as 'a)
+end;;
+
+module type S =
+    sig module M : sig type t end end with module M = M
+;;
+module type Printable = sig
+  type t
+  val print : Format.formatter -> t -> unit
+end;;
+module type Comparable = sig
+  type t
+  val compare : t -> t -> int
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t = t
+end;; (* Fails *)
+module type PrintableComparable = sig
+  type t
+  include Printable with type t := t
+  include Comparable with type t := t
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t := t
+end;;
+module type ComparableInt = Comparable with type t := int;;
+module type S = sig type t val f : t -> t end;;
+module type S' = S with type t := int;;
+
+module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end;;
+module type S1 = S with type 'a t := 'a list;;
+module type S2 = sig
+  type 'a dict = (string * 'a) list
+  include S with type 'a t := 'a dict
+end;;
+
+
+module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end;;
+module M = struct type exp = string type arg = int end;;
+module type S' = S with module T := M;;
+
+
+module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)
+let property (type t) () =
+  let module M = struct exception E of t end in
+  (fun x -> M.E x), (function M.E x -> Some x | _ -> None)
+;;
+
+let () =
+  let (int_inj, int_proj) = property () in
+  let (string_inj, string_proj) = property () in
+
+  let i = int_inj 3 in
+  let s = string_inj "abc" in
+
+  Printf.printf "%b\n%!" (int_proj i = None);
+  Printf.printf "%b\n%!" (int_proj s = None);
+  Printf.printf "%b\n%!" (string_proj i = None);
+  Printf.printf "%b\n%!" (string_proj s = None)
+;;
+
+let sort_uniq (type s) cmp l =
+  let module S = Set.Make(struct type t = s let compare = cmp end) in
+  S.elements (List.fold_right S.add l S.empty)
+;;
+
+let () =
+  print_endline (String.concat "," (sort_uniq compare [ "abc"; "xyz"; "abc" ]))
+;;
+
+let f x (type a) (y : a) = (x = y);; (* Fails *)
+class ['a] c = object (self)
+  method m : 'a -> 'a = fun x -> x
+  method n : 'a -> 'a = fun (type g) (x:g) -> self#m x
+end;; (* Fails *)
+
+external a : (int [@untagged]) -> unit = "a" "a_nat"
+external b : (int32 [@unboxed]) -> unit = "b" "b_nat"
+external c : (int64 [@unboxed]) -> unit = "c" "c_nat"
+external d : (nativeint [@unboxed]) -> unit = "d" "d_nat"
+external e : (float [@unboxed]) -> unit = "e" "e_nat"
+
+type t = private int
+
+external f : (t [@untagged]) -> unit = "f" "f_nat"
+
+module M : sig
+  external a : int -> (int [@untagged]) = "a" "a_nat"
+  external b : (int [@untagged]) -> int = "b" "b_nat"
+end = struct
+  external a : int -> (int [@untagged]) = "a" "a_nat"
+  external b : (int [@untagged]) -> int = "b" "b_nat"
+end;;
+
+module Global_attributes = struct
+  [@@@ocaml.warning "-3"]
+
+  external a : float -> float = "a" "noalloc" "a_nat" "float"
+  external b : float -> float = "b" "noalloc" "b_nat"
+  external c : float -> float = "c" "c_nat" "float"
+  external d : float -> float = "d" "noalloc"
+  external e : float -> float = "e"
+
+  (* Should output a warning: no native implementation provided *)
+  external f : (int32 [@unboxed]) -> (int32 [@unboxed]) = "f" "noalloc"
+  external g : int32 -> int32 = "g" "g_nat" [@@unboxed] [@@noalloc]
+
+  external h : (int [@untagged]) -> (int [@untagged]) = "h" "h_nat" "noalloc"
+  external i : int -> int = "i" "i_nat" [@@untagged] [@@noalloc]
+end;;
+
+module Old_style_warning = struct
+  [@@@ocaml.warning "+3"]
+  external a : float -> float = "a" "noalloc" "a_nat" "float"
+  external b : float -> float = "b" "noalloc" "b_nat"
+  external c : float -> float = "c" "c_nat" "float"
+  external d : float -> float = "d" "noalloc"
+  external e : float -> float = "c" "float"
+end
+
+(* Bad: attributes not reported in the interface *)
+
+module Bad1 : sig
+  external f : int -> int = "f" "f_nat"
+end = struct
+  external f : int -> (int [@untagged]) = "f" "f_nat"
+end;;
+
+module Bad2 : sig
+  external f : int -> int = "a" "a_nat"
+end = struct
+  external f : (int [@untagged]) -> int = "f" "f_nat"
+end;;
+
+module Bad3 : sig
+  external f : float -> float = "f" "f_nat"
+end = struct
+  external f : float -> (float [@unboxed]) = "f" "f_nat"
+end;;
+
+module Bad4 : sig
+  external f : float -> float = "a" "a_nat"
+end = struct
+  external f : (float [@unboxed]) -> float = "f" "f_nat"
+end;;
+
+(* Bad: attributes in the interface but not in the implementation *)
+
+module Bad5 : sig
+  external f : int -> (int [@untagged]) = "f" "f_nat"
+end = struct
+  external f : int -> int = "f" "f_nat"
+end;;
+
+module Bad6 : sig
+  external f : (int [@untagged]) -> int = "f" "f_nat"
+end = struct
+  external f : int -> int = "a" "a_nat"
+end;;
+
+module Bad7 : sig
+  external f : float -> (float [@unboxed]) = "f" "f_nat"
+end = struct
+  external f : float -> float = "f" "f_nat"
+end;;
+
+module Bad8 : sig
+  external f : (float [@unboxed]) -> float = "f" "f_nat"
+end = struct
+  external f : float -> float = "a" "a_nat"
+end;;
+
+(* Bad: unboxed or untagged with the wrong type *)
+
+external g : (float [@untagged]) -> float = "g" "g_nat";;
+external h : (int [@unboxed]) -> float = "h" "h_nat";;
+
+(* Bad: unboxing the function type *)
+external i : int -> float [@unboxed] = "i" "i_nat";;
+
+(* Bad: unboxing a "deep" sub-type. *)
+external j : int -> (float [@unboxed]) * float = "j" "j_nat";;
+
+(* This should be rejected, but it is quite complicated to do
+   in the current state of things *)
+
+external k : int -> (float [@unboxd]) = "k" "k_nat";;
+
+(* Bad: old style annotations + new style attributes *)
+
+external l : float -> float = "l" "l_nat" "float" [@@unboxed];;
+external m : (float [@unboxed]) -> float = "m" "m_nat" "float";;
+external n : float -> float = "n" "noalloc" [@@noalloc];;
+
+(* Warnings: unboxed / untagged without any native implementation *)
+external o : (float[@unboxed]) -> float = "o";;
+external p : float -> (float[@unboxed]) = "p";;
+external q : (int[@untagged]) -> float = "q";;
+external r : int -> (int[@untagged]) = "r";;
+external s : int -> int = "s" [@@untagged];;
+external t : float -> float = "t" [@@unboxed];;
+let _ = ignore (+);;
+let _ = raise Exit 3;;
+(* comment 9644 of PR#6000 *)
+
+fun b -> if b then format_of_string "x" else "y";;
+fun b -> if b then "x" else format_of_string "y";;
+fun b : (_,_,_) format -> if b then "x" else "y";;
+
+(* PR#7135 *)
+
+module PR7135 = struct
+  module M : sig type t = private int end =  struct type t = int end
+  include M
+
+  let lift2 (f : int -> int -> int) (x : t) (y : t) =
+    f (x :> int) (y :> int)
+end;;
+
+(* exemple of non-ground coercion *)
+
+module Test1 = struct
+  type t = private int
+  let f x = let y = if true then x else (x:t) in (y :> int)
+end;;
+(* Warn about all relevant cases when possible *)
+let f = function
+    None, None -> 1
+  | Some _, Some _ -> 2;;
+
+(* Exhaustiveness check is very slow *)
+type _ t =
+  A : int t | B : bool t | C : char t | D : float t
+type (_,_,_,_) u = U : (int, int, int, int) u
+type v = E | F | G
+;;
+
+let f : type a b c d e f g.
+      a t * b t * c t * d t * e t * f t * g t * v
+       * (a,b,c,d) u * (e,f,g,g) u -> int =
+ function A, A, A, A, A, A, A, _, U, U -> 1
+   | _, _, _, _, _, _, _, G, _, _ -> 1
+   (*| _ -> _ *)
+;;
+
+(* Unused cases *)
+let f (x : int t) = match x with A -> 1 | _ -> 2;; (* warn *)
+let f (x : unit t option) = match x with None -> 1 | _ -> 2 ;; (* warn? *)
+let f (x : unit t option) = match x with None -> 1 | Some _ -> 2 ;; (* warn *)
+let f (x : int t option) = match x with None -> 1 | _ -> 2;;
+let f (x : int t option) = match x with None -> 1;; (* warn *)
+
+(* Example with record, type, single case *)
+
+type 'a box = Box of 'a
+type 'a pair = {left: 'a; right: 'a};;
+
+let f : (int t box pair * bool) option -> unit = function None -> ();;
+let f : (string t box pair * bool) option -> unit = function None -> ();;
+
+
+(* Examples from ML2015 paper *)
+
+type _ t =
+  | Int : int t
+  | Bool : bool t
+;;
+
+let f : type a. a t -> a = function
+  | Int -> 1
+  | Bool -> true
+;;
+let g : int t -> int = function
+  | Int -> 1
+;;
+let h : type a. a t -> a t -> bool =
+  fun x y -> match x, y with
+  | Int, Int -> true
+  | Bool, Bool -> true
+;;
+type (_, _) cmp =
+ | Eq : ('a, 'a) cmp
+ | Any: ('a, 'b) cmp
+module A : sig type a type b val eq : (a, b) cmp end
+  = struct type a type b = a let eq = Eq end
+;;
+let f : (A.a, A.b) cmp -> unit = function Any -> ()
+;;
+let deep : char t option -> char =
+  function None -> 'c'
+;;
+type zero = Zero
+type _ succ = Succ
+;;
+type (_,_,_) plus =
+  | Plus0 : (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus ->
+       ('a succ, 'b, 'c succ) plus
+;;
+let trivial : (zero succ, zero, zero) plus option -> bool =
+  function None -> false
+;;
+let easy : (zero, zero succ, zero) plus option -> bool =
+  function None -> false
+;;
+let harder : (zero succ, zero succ, zero succ) plus option -> bool =
+  function None -> false
+;;
+let harder : (zero succ, zero succ, zero succ) plus option  -> bool =
+  function None -> false | Some (PlusS _) -> .
+;;
+let inv_zero : type a b c d. (a,b,c) plus -> (c,d,zero) plus -> bool =
+  fun p1 p2 ->
+    match p1, p2 with
+    | Plus0, Plus0 -> true
+;;
+
+
+(* Empty match *)
+
+type _ t = Int : int t;;
+let f (x : bool t) = match x with _ -> . ;; (* ok *)
+
+
+(* trefis in PR#6437 *)
+
+let f () = match None with _ -> .;; (* error *)
+let g () = match None with _ -> () | exception _ -> .;; (* error *)
+let h () = match None with _ -> .  | exception _ -> .;; (* error *)
+let f x = match x with _ -> () | None -> .;; (* do not warn *)
+
+(* #7059, all clauses guarded *)
+
+let f x y = match 1 with 1 when x = y -> 1;;
+open CamlinternalOO;;
+type _ choice = Left : label choice | Right : tag choice;;
+let f : label choice -> bool = function Left -> true;; (* warn *)
+exception A;;
+type a = A;;
+
+A;;
+raise A;;
+fun (A : a) -> ();;
+function Not_found -> 1 | A -> 2 | _ -> 3;;
+try raise A with A -> 2;;
+module TypEq = struct
+ type (_, _) t = Eq : ('a, 'a) t
+end
+
+module type T = sig
+ type _ is_t = Is : ('a, 'b) TypEq.t -> 'a is_t
+ val is_t : unit -> unit is_t option
+end
+
+module Make (M : T) =
+ struct
+   let _ =
+     match M.is_t () with
+     | None -> 0
+     | Some _ -> 0
+   let f () =
+     match M.is_t () with None -> 0
+end;;
+
+module Make2 (M : T) = struct
+  type t = T of unit M.is_t
+  let g : t -> int = function _ -> .
+end;;
+type t = A : t;;
+
+module X1 : sig end = struct
+  let _f ~x (* x unused argument *) = function
+    | A -> let x = () in x
+end;;
+
+module X2 : sig end = struct
+  let x = 42 (* unused value *)
+  let _f = function
+    | A -> let x = () in x
+end;;
+
+module X3 : sig end = struct
+  module O = struct let x = 42 (* unused *) end
+  open O (* unused open *)
+
+  let _f = function
+    | A -> let x = () in x
+end;;
+(* Use type information *)
+module M1 = struct
+  type t = {x: int; y: int}
+  type u = {x: bool; y: bool}
+end;;
+
+module OK = struct
+  open M1
+  let f1 (r:t) = r.x (* ok *)
+  let f2 r = ignore (r:t); r.x (* non principal *)
+
+  let f3 (r: t) =
+    match r with {x; y} -> y + y (* ok *)
+end;;
+
+module F1 = struct
+  open M1
+  let f r = match r with {x; y} -> y + y
+end;; (* fails *)
+
+module F2 = struct
+  open M1
+  let f r =
+    ignore (r: t);
+    match r with
+       {x; y} -> y + y
+end;; (* fails for -principal *)
+
+(* Use type information with modules*)
+module M = struct
+  type t = {x:int}
+  type u = {x:bool}
+end;;
+let f (r:M.t) = r.M.x;; (* ok *)
+let f (r:M.t) = r.x;; (* warning *)
+let f ({x}:M.t) = x;; (* warning *)
+
+module M = struct
+  type t = {x: int; y: int}
+end;;
+module N = struct
+  type u = {x: bool; y: bool}
+end;;
+module OK = struct
+  open M
+  open N
+  let f (r:M.t) = r.x
+end;;
+
+module M = struct
+  type t = {x:int}
+  module N = struct type s = t = {x:int} end
+  type u = {x:bool}
+end;;
+module OK = struct
+  open M.N
+  let f (r:M.t) = r.x
+end;;
+
+(* Use field information *)
+module M = struct
+  type u = {x:bool;y:int;z:char}
+  type t = {x:int;y:bool}
+end;;
+module OK = struct
+  open M
+  let f {x;z} = x,z
+end;; (* ok *)
+module F3 = struct
+  open M
+  let r = {x=true;z='z'}
+end;; (* fail for missing label *)
+
+module OK = struct
+  type u = {x:int;y:bool}
+  type t = {x:bool;y:int;z:char}
+  let r = {x=3; y=true}
+end;; (* ok *)
+
+(* Corner cases *)
+
+module F4 = struct
+  type foo = {x:int; y:int}
+  type bar = {x:int}
+  let b : bar = {x=3; y=4}
+end;; (* fail but don't warn *)
+
+module M = struct type foo = {x:int;y:int} end;;
+module N = struct type bar = {x:int;y:int} end;;
+let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+
+module MN = struct include M include N end
+module NM = struct include N include M end;;
+let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+
+(* Lpw25 *)
+
+module M = struct
+  type foo = { x: int; y: int }
+  type bar = { x:int; y: int; z: int}
+end;;
+module F5 = struct
+  open M
+  let f r = ignore (r: foo); {r with x = 2; z = 3}
+end;;
+module M = struct
+  include M
+  type other = { a: int; b: int }
+end;;
+module F6 = struct
+  open M
+  let f r = ignore (r: foo); { r with x = 3; a = 4 }
+end;;
+module F7 = struct
+  open M
+  let r = {x=1; y=2}
+  let r: other = {x=1; y=2}
+end;;
+
+module A = struct type t = {x: int} end
+module B = struct type t = {x: int} end;;
+let f (r : B.t) = r.A.x;; (* fail *)
+
+(* Spellchecking *)
+
+module F8 = struct
+  type t = {x:int; yyy:int}
+  let a : t = {x=1;yyz=2}
+end;;
+
+(* PR#6004 *)
+
+type t = A
+type s = A
+
+class f (_ : t) = object end;;
+class g = f A;; (* ok *)
+
+class f (_ : 'a) (_ : 'a) = object end;;
+class g = f (A : t) A;; (* warn with -principal *)
+
+
+(* PR#5980 *)
+
+module Shadow1 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open is unused, it isn't reported as shadowing 'x' *)
+  let y : t = {x = 0}
+end;;
+module Shadow2 = struct
+  type t = {x: int}
+  module M = struct
+    type s = {x: string}
+  end
+  open M  (* this open shadows label 'x' *)
+  let y = {x = ""}
+end;;
+
+(* PR#6235 *)
+
+module P6235 = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f (u : u) = match u with `Key {loc} -> loc
+end;;
+
+(* Remove interaction between branches *)
+
+module P6235' = struct
+  type t = { loc : string; }
+  type v = { loc : string; x : int; }
+  type u = [ `Key of t ]
+  let f = function
+    | (_ : u) when false -> ""
+    |`Key {loc} -> loc
+end;;
+module Unused : sig
+end = struct
+  type unused = int
+end
+;;
+
+module Unused_nonrec : sig
+end = struct
+  type nonrec used = int
+  type nonrec unused = used
+end
+;;
+
+module Unused_rec : sig
+end = struct
+  type unused = A of unused
+end
+;;
+
+module Unused_exception : sig
+end = struct
+  exception Nobody_uses_me
+end
+;;
+
+module Unused_extension_constructor : sig
+  type t = ..
+end = struct
+  type t = ..
+  type t += Nobody_uses_me
+end
+;;
+
+module Unused_exception_outside_patterns : sig
+  val falsity : exn -> bool
+end = struct
+  exception Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_extension_outside_patterns : sig
+  type t = ..
+  val falsity : t -> bool
+end = struct
+  type t = ..
+  type t += Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_private_exception : sig
+  type exn += private Private_exn
+end = struct
+  exception Private_exn
+end
+;;
+
+module Unused_private_extension : sig
+  type t = ..
+  type t += private Private_ext
+end = struct
+  type t = ..
+  type t += Private_ext
+end
+;;
+
+for i = 10 downto 0 do () done
+
+type t = < foo: int [@foo] >
+
+let _ = [%foo: < foo : t > ]
+
+type foo += private A of int
+
+let f : 'a 'b 'c. < .. > = assert false
+
+let () =
+  let module M = (functor (T : sig end) -> struct end)(struct end) in ()
+
+class c = object inherit ((fun () -> object end [@wee]: object end) ()) end
+
+
+let f = function x[@wee] -> ()
+let f = function
+  | '1'..'9' | '1' .. '8'-> ()
+  | 'a'..'z' -> ()
+
+let f = function
+  | [| x1; x2 |] -> ()
+  | [| |] -> ()
+  | [|x|][@foo] -> ()
+  | _ -> ()
+
+let g = function
+  | {l=x} -> ()
+  | {l1=x; l2=y}[@foo] -> ()
+  | {l1=x; l2=y; _} -> ()
+
+let h = fun ?l:(p=1) ?y:u ?x:(x=3) -> 2
+
+let _ = function
+  | a, s, ba1, ba2, ba3, bg -> begin
+      ignore (Array.get x 1 + Array.get [| |] 0 +
+              Array.get [| 1 |] 1 + Array.get [|1; 2|] 2);
+      ignore ([String.get s 1; String.get "" 2; String.get "123" 3]);
+      ignore (ba1.{0} + ba2.{1, 2} + ba3.{3, 4, 5})
+      ignore (bg.{1, 2, 3, 4})
+    end
+  | b, s, ba1, ba2, ba3, bg -> begin
+      y.(0) <- 1; s.[1] <- 'c';
+      ba1.{1} <- 2; ba2.{1, 2} <- 3; ba3.{1, 2, 3} <- 4;
+      bg.{1, 2, 3, 4, 5} <- 0
+    end
+
+let f (type t) () =
+  let exception F of t in ();
+  let exception G of t in ();
+  let exception E of t in
+  (fun x -> E x), (function E _ -> print_endline "OK" | _ -> print_endline "KO")
+
+let inj1, proj1 = f ()
+let inj2, proj2 = f ()
+
+let () = proj1 (inj1 42)
+let () = proj1 (inj2 42)
+
+let _ = ~-1
+
+class id = [%exp]
+(* checkpoint *)
+
+(* Subtyping is "syntactic" *)
+let _ = fun (x : < x : int >) y z -> (y :> 'a), (x :> 'a), (z :> 'a);;
+(* - : (< x : int > as 'a) -> 'a -> 'a * 'a = <fun> *)
+
+(*
+class ['a] c () = object
+  method f = (new c (): int c)
+end and ['a] d () = object
+  inherit ['a] c ()
+end;;
+*)
+
+(* PR#7329 Pattern open *)
+let _ =
+  let module M = struct type t = { x : int } end in
+  let f M.(x) = () in
+  let g M.{x} = () in
+  let h = function M.[] | M.[a] | M.(a::q) -> () in
+  let i = function M.[||] | M.[|x|]  -> true | _ -> false in
+  ()

diff --git a/testsuite/tests/parsetree/test.ml b/testsuite/tests/parsetree/test.ml
new file mode 100644 (file)
index 0000000..ba8819d
--- /dev/null
+++ b/testsuite/tests/parsetree/test.ml
@@ -0,0 +1,102 @@
+(* (c) Alain Frisch / Lexifi *)
+(* cf. PR#7200 *)
+let report_err exn =
+  match exn with
+    | Sys_error msg ->
+        Format.printf "@[I/O error:@ %s@]@." msg
+    | x ->
+        match Location.error_of_exn x with
+        | Some err ->
+            Format.printf "@[%a@]@."
+              Location.report_error err
+        | None -> raise x
+
+let remove_locs =
+  let open Ast_mapper in
+  { default_mapper with
+    location = (fun _mapper _loc -> Location.none);
+    attributes =
+      (fun mapper attrs ->
+         let attrs = default_mapper.attributes mapper attrs in
+         List.filter (fun (s, _) -> s.Location.txt <> "#punning#")
+           attrs (* this is to accomodate a LexiFi custom extension *)
+      )
+  }
+
+let from_file parse_fun filename =
+  Location.input_name := filename;
+  let ic = open_in filename in
+  let lexbuf = Lexing.from_channel ic in
+  Location.init lexbuf filename;
+  let ast = parse_fun lexbuf in
+  close_in ic;
+  ast
+
+let from_string parse_fun str =
+  Location.input_name := "<str>";
+  let lexbuf = Lexing.from_string str in
+  Location.init lexbuf "<str>";
+  parse_fun lexbuf
+
+let to_string print_fun ast =
+  Format.fprintf Format.str_formatter "%a@." print_fun ast;
+  Format.flush_str_formatter ()
+
+let to_tmp_file print_fun ast =
+  let fn, oc = Filename.open_temp_file "ocamlparse" ".txt" in
+  output_string oc (to_string print_fun ast);
+  close_out oc;
+  fn
+
+let test parse_fun pprint print map filename =
+  match from_file parse_fun filename with
+  | exception exn ->
+      Printf.printf "%s: FAIL, CANNOT PARSE\n" filename;
+      report_err exn;
+      print_endline "====================================================="
+  | ast ->
+      let str = to_string pprint ast in
+      match from_string parse_fun str with
+      | exception exn ->
+          Printf.printf "%s: FAIL, CANNOT REPARSE\n" filename;
+          report_err exn;
+          print_endline str;
+          print_endline "====================================================="
+      | ast2 ->
+          let ast = map remove_locs remove_locs ast in
+          let ast2 = map remove_locs remove_locs ast2 in
+          if ast <> ast2 then begin
+            Printf.printf "%s:  FAIL, REPARSED AST IS DIFFERENT\n%!" filename;
+            let f1 = to_tmp_file print ast in
+            let f2 = to_tmp_file print ast2 in
+            let cmd = Printf.sprintf "diff -u %s %s"
+                (Filename.quote f1) (Filename.quote f2) in
+            let _ret = Sys.command cmd in
+            print_endline"====================================================="
+          end
+
+let test parse_fun pprint print map filename =
+  try test parse_fun pprint print map filename
+  with exn -> report_err exn
+
+let rec process path =
+  if Sys.is_directory path then
+    let files = Sys.readdir path in
+    Array.iter (fun s -> process (Filename.concat path s)) files
+  else if Filename.check_suffix path ".ml" then
+    test
+      Parse.implementation
+      Pprintast.structure
+      Printast.implementation
+      (fun mapper -> mapper.Ast_mapper.structure)
+      path
+  else if Filename.check_suffix path ".mli" then
+    test
+      Parse.interface
+      Pprintast.signature
+      Printast.interface
+      (fun mapper -> mapper.Ast_mapper.signature)
+      path
+
+let () =
+  process "source.ml"

diff --git a/testsuite/tests/parsetree/test.reference b/testsuite/tests/parsetree/test.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/parsing/extensions.ml.reference b/testsuite/tests/parsing/extensions.ml.reference
index bd14c5d32adeff1d88e92314f847c3791b9d891c..e904d7e9a77f77dda1120c92668f6f2c306e2a61 100644 (file)
--- a/testsuite/tests/parsing/extensions.ml.reference
+++ b/testsuite/tests/parsing/extensions.ml.reference
@@ -323,4 +323,4 @@
 ]
 
 File "extensions.ml", line 2, characters 3-6:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.

diff --git a/testsuite/tests/parsing/pr6865.ml.reference b/testsuite/tests/parsing/pr6865.ml.reference
index 55a541fbc2edf37d547e3f8b13c8d3bef4d0a9d1..72abd40e11fcaf337ea60bea83cb0306f307e5b6 100644 (file)
--- a/testsuite/tests/parsing/pr6865.ml.reference
+++ b/testsuite/tests/parsing/pr6865.ml.reference
@@ -49,4 +49,4 @@
 ]
 
 File "pr6865.ml", line 1, characters 4-7:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.

diff --git a/testsuite/tests/parsing/pr7165.ml b/testsuite/tests/parsing/pr7165.ml
new file mode 100644 (file)
index 0000000..ba6835b
--- /dev/null
+++ b/testsuite/tests/parsing/pr7165.ml
@@ -0,0 +1,4 @@
+(* this is a lexer directive with an out-of-bound integer;
+   it should result in a lexing error instead of an
+   uncaught exception as in PR#7165 *)
+#9342101923012312312

diff --git a/testsuite/tests/parsing/pr7165.ml.reference b/testsuite/tests/parsing/pr7165.ml.reference
new file mode 100644 (file)
index 0000000..fd59df8
--- /dev/null
+++ b/testsuite/tests/parsing/pr7165.ml.reference
@@ -0,0 +1,2 @@
+File "pr7165.ml", line 4, characters 0-21:
+Error: Invalid lexer directive "#9342101923012312312": line number out of range

diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml b/testsuite/tests/parsing/shortcut_ext_attr.ml
index e65a663c4128d111c84ed59c1c399a2a8596cd55..7f6d1f51c151fd7fb355d07b78a9252480f6b23b 100644 (file)
--- a/testsuite/tests/parsing/shortcut_ext_attr.ml
+++ b/testsuite/tests/parsing/shortcut_ext_attr.ml
@@ -11,6 +11,7 @@ let () =
   (if%foo[@foo] () then () else ()) ;
   while%foo[@foo] () do () done ;
   for%foo[@foo] x = () to () do () done ;
+  () ;%foo () ;
   assert%foo[@foo] true ;
   lazy%foo[@foo] x ;
   object%foo[@foo] end ;

diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference
index 27c32e16c143256746771db147eb67e7e728a3a6..c31013494a95e1e13a221bc30746bdab2abc4afc 100644 (file)
--- a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference
+++ b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference
@@ -1,17 +1,17 @@
 [
-  structure_item (shortcut_ext_attr.ml[3,19+0]..[23,554+31])
+  structure_item (shortcut_ext_attr.ml[3,19+0]..[24,570+31])
     Pstr_value Nonrec
     [
       <def>
         pattern (shortcut_ext_attr.ml[3,19+4]..[3,19+6])
           Ppat_construct "()" (shortcut_ext_attr.ml[3,19+4]..[3,19+6])
           None
-        expression (shortcut_ext_attr.ml[4,28+2]..[23,554+31]) ghost
+        expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31]) ghost
           Pexp_extension "foo"
           [
-            structure_item (shortcut_ext_attr.ml[4,28+2]..[23,554+31])
+            structure_item (shortcut_ext_attr.ml[4,28+2]..[24,570+31])
               Pstr_eval
-              expression (shortcut_ext_attr.ml[4,28+2]..[23,554+31])
+              expression (shortcut_ext_attr.ml[4,28+2]..[24,570+31])
                 Pexp_let Nonrec
                 [
                   <def>
@@ -29,7 +29,7 @@
                     expression (shortcut_ext_attr.ml[5,50+16]..[5,50+17])
                       Pexp_constant PConst_int (4,None)
                 ]
-                expression (shortcut_ext_attr.ml[6,71+2]..[23,554+31])
+                expression (shortcut_ext_attr.ml[6,71+2]..[24,570+31])
                   Pexp_sequence
                   expression (shortcut_ext_attr.ml[6,71+2]..[6,71+36])
                     Pexp_extension "foo"
@@ -46,7 +46,7 @@
                             Pexp_construct "()" (shortcut_ext_attr.ml[6,71+33]..[6,71+35])
                             None
                     ]
-                  expression (shortcut_ext_attr.ml[7,110+2]..[23,554+31])
+                  expression (shortcut_ext_attr.ml[7,110+2]..[24,570+31])
                     Pexp_sequence
                     expression (shortcut_ext_attr.ml[7,110+2]..[7,110+30])
                       Pexp_extension "foo"
@@ -61,7 +61,7 @@
                               Pexp_construct "()" (shortcut_ext_attr.ml[7,110+27]..[7,110+29])
                               None
                       ]
-                    expression (shortcut_ext_attr.ml[8,143+2]..[23,554+31])
+                    expression (shortcut_ext_attr.ml[8,143+2]..[24,570+31])
                       Pexp_sequence
                       expression (shortcut_ext_attr.ml[8,143+2]..[8,143+25])
                         Pexp_extension "foo"
@@ -80,7 +80,7 @@
                                 Pexp_construct "()" (shortcut_ext_attr.ml[8,143+22]..[8,143+24])
                                 None
                         ]
-                      expression (shortcut_ext_attr.ml[9,171+2]..[23,554+31])
+                      expression (shortcut_ext_attr.ml[9,171+2]..[24,570+31])
                         Pexp_sequence
                         expression (shortcut_ext_attr.ml[9,171+2]..[9,171+30])
                           Pexp_extension "foo"
@@ -100,7 +100,7 @@
                                       None
                                 ]
                           ]
-                        expression (shortcut_ext_attr.ml[10,204+2]..[23,554+31])
+                        expression (shortcut_ext_attr.ml[10,204+2]..[24,570+31])
                           Pexp_sequence
                           expression (shortcut_ext_attr.ml[10,204+2]..[10,204+33])
                             Pexp_extension "foo"
@@ -123,7 +123,7 @@
                                         None
                                   ]
                             ]
-                          expression (shortcut_ext_attr.ml[11,240+2]..[23,554+31])
+                          expression (shortcut_ext_attr.ml[11,240+2]..[24,570+31])
                             Pexp_sequence
                             expression (shortcut_ext_attr.ml[11,240+2]..[11,240+35])
                               Pexp_extension "foo"
@@ -145,7 +145,7 @@
                                         Pexp_construct "()" (shortcut_ext_attr.ml[11,240+32]..[11,240+34])
                                         None
                               ]
-                            expression (shortcut_ext_attr.ml[12,278+2]..[23,554+31])
+                            expression (shortcut_ext_attr.ml[12,278+2]..[24,570+31])
                               Pexp_sequence
                               expression (shortcut_ext_attr.ml[12,278+2]..[12,278+31]) ghost
                                 Pexp_extension "foo"
@@ -163,7 +163,7 @@
                                         Pexp_construct "()" (shortcut_ext_attr.ml[12,278+24]..[12,278+26])
                                         None
                                 ]
-                              expression (shortcut_ext_attr.ml[13,312+2]..[23,554+31])
+                              expression (shortcut_ext_attr.ml[13,312+2]..[24,570+31])
                                 Pexp_sequence
                                 expression (shortcut_ext_attr.ml[13,312+2]..[13,312+39]) ghost
                                   Pexp_extension "foo"
@@ -186,292 +186,308 @@
                                           Pexp_construct "()" (shortcut_ext_attr.ml[13,312+32]..[13,312+34])
                                           None
                                   ]
-                                expression (shortcut_ext_attr.ml[14,354+2]..[23,554+31])
-                                  Pexp_sequence
-                                  expression (shortcut_ext_attr.ml[14,354+2]..[14,354+23]) ghost
-                                    Pexp_extension "foo"
-                                    [
-                                      structure_item (shortcut_ext_attr.ml[14,354+2]..[14,354+23])
-                                        Pstr_eval
-                                        expression (shortcut_ext_attr.ml[14,354+2]..[14,354+23])
-                                          attribute "foo"
-                                            []
-                                          Pexp_assert
-                                          expression (shortcut_ext_attr.ml[14,354+19]..[14,354+23])
-                                            Pexp_construct "true" (shortcut_ext_attr.ml[14,354+19]..[14,354+23])
-                                            None
-                                    ]
-                                  expression (shortcut_ext_attr.ml[15,380+2]..[23,554+31])
-                                    Pexp_sequence
-                                    expression (shortcut_ext_attr.ml[15,380+2]..[15,380+18]) ghost
-                                      Pexp_extension "foo"
-                                      [
-                                        structure_item (shortcut_ext_attr.ml[15,380+2]..[15,380+18])
-                                          Pstr_eval
-                                          expression (shortcut_ext_attr.ml[15,380+2]..[15,380+18])
-                                            attribute "foo"
-                                              []
-                                            Pexp_lazy
-                                            expression (shortcut_ext_attr.ml[15,380+17]..[15,380+18])
-                                              Pexp_ident "x" (shortcut_ext_attr.ml[15,380+17]..[15,380+18])
-                                      ]
-                                    expression (shortcut_ext_attr.ml[16,401+2]..[23,554+31])
-                                      Pexp_sequence
-                                      expression (shortcut_ext_attr.ml[16,401+2]..[16,401+22]) ghost
-                                        Pexp_extension "foo"
-                                        [
-                                          structure_item (shortcut_ext_attr.ml[16,401+2]..[16,401+22])
-                                            Pstr_eval
-                                            expression (shortcut_ext_attr.ml[16,401+2]..[16,401+22])
-                                              attribute "foo"
-                                                []
-                                              Pexp_object
-                                              class_structure
-                                                pattern (shortcut_ext_attr.ml[16,401+18]..[16,401+18]) ghost
-                                                  Ppat_any
-                                                []
-                                        ]
-                                      expression (shortcut_ext_attr.ml[17,426+2]..[23,554+31])
+                                expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
+                                  Pexp_extension "foo"
+                                  [
+                                    structure_item (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
+                                      Pstr_eval
+                                      expression (shortcut_ext_attr.ml[14,354+2]..[24,570+31])
                                         Pexp_sequence
-                                        expression (shortcut_ext_attr.ml[17,426+2]..[17,426+23]) ghost
-                                          Pexp_extension "foo"
-                                          [
-                                            structure_item (shortcut_ext_attr.ml[17,426+2]..[17,426+23])
-                                              Pstr_eval
-                                              expression (shortcut_ext_attr.ml[17,426+2]..[17,426+23])
-                                                attribute "foo"
-                                                  []
-                                                Pexp_constant PConst_int (3,None)
-                                          ]
-                                        expression (shortcut_ext_attr.ml[18,452+2]..[23,554+31])
+                                        expression (shortcut_ext_attr.ml[14,354+2]..[14,354+4])
+                                          Pexp_construct "()" (shortcut_ext_attr.ml[14,354+2]..[14,354+4])
+                                          None
+                                        expression (shortcut_ext_attr.ml[14,354+11]..[24,570+31])
                                           Pexp_sequence
-                                          expression (shortcut_ext_attr.ml[18,452+2]..[18,452+17]) ghost
-                                            Pexp_extension "foo"
-                                            [
-                                              structure_item (shortcut_ext_attr.ml[18,452+2]..[18,452+17])
-                                                Pstr_eval
-                                                expression (shortcut_ext_attr.ml[18,452+2]..[18,452+17])
-                                                  attribute "foo"
-                                                    []
-                                                  Pexp_new "x" (shortcut_ext_attr.ml[18,452+16]..[18,452+17])
-                                            ]
-                                          expression (shortcut_ext_attr.ml[20,473+2]..[23,554+31]) ghost
-                                            Pexp_extension "foo"
-                                            [
-                                              structure_item (shortcut_ext_attr.ml[20,473+2]..[23,554+31])
-                                                Pstr_eval
-                                                expression (shortcut_ext_attr.ml[20,473+2]..[23,554+31])
-                                                  attribute "foo"
-                                                    []
-                                                  Pexp_match
-                                                  expression (shortcut_ext_attr.ml[20,473+18]..[20,473+20])
-                                                    Pexp_construct "()" (shortcut_ext_attr.ml[20,473+18]..[20,473+20])
-                                                    None
+                                          expression (shortcut_ext_attr.ml[14,354+11]..[14,354+13])
+                                            Pexp_construct "()" (shortcut_ext_attr.ml[14,354+11]..[14,354+13])
+                                            None
+                                          expression (shortcut_ext_attr.ml[15,370+2]..[24,570+31])
+                                            Pexp_sequence
+                                            expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23]) ghost
+                                              Pexp_extension "foo"
+                                              [
+                                                structure_item (shortcut_ext_attr.ml[15,370+2]..[15,370+23])
+                                                  Pstr_eval
+                                                  expression (shortcut_ext_attr.ml[15,370+2]..[15,370+23])
+                                                    attribute "foo"
+                                                      []
+                                                    Pexp_assert
+                                                    expression (shortcut_ext_attr.ml[15,370+19]..[15,370+23])
+                                                      Pexp_construct "true" (shortcut_ext_attr.ml[15,370+19]..[15,370+23])
+                                                      None
+                                              ]
+                                            expression (shortcut_ext_attr.ml[16,396+2]..[24,570+31])
+                                              Pexp_sequence
+                                              expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18]) ghost
+                                                Pexp_extension "foo"
+                                                [
+                                                  structure_item (shortcut_ext_attr.ml[16,396+2]..[16,396+18])
+                                                    Pstr_eval
+                                                    expression (shortcut_ext_attr.ml[16,396+2]..[16,396+18])
+                                                      attribute "foo"
+                                                        []
+                                                      Pexp_lazy
+                                                      expression (shortcut_ext_attr.ml[16,396+17]..[16,396+18])
+                                                        Pexp_ident "x" (shortcut_ext_attr.ml[16,396+17]..[16,396+18])
+                                                ]
+                                              expression (shortcut_ext_attr.ml[17,417+2]..[24,570+31])
+                                                Pexp_sequence
+                                                expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22]) ghost
+                                                  Pexp_extension "foo"
                                                   [
-                                                    <case>
-                                                      pattern (shortcut_ext_attr.ml[22,527+4]..[22,527+20]) ghost
-                                                        Ppat_extension "foo"
-                                                        pattern (shortcut_ext_attr.ml[22,527+4]..[22,527+20])
-                                                          attribute "foo"
-                                                            []
-                                                          Ppat_lazy
-                                                          pattern (shortcut_ext_attr.ml[22,527+19]..[22,527+20])
-                                                            Ppat_var "x" (shortcut_ext_attr.ml[22,527+19]..[22,527+20])
-                                                      expression (shortcut_ext_attr.ml[22,527+24]..[22,527+26])
-                                                        Pexp_construct "()" (shortcut_ext_attr.ml[22,527+24]..[22,527+26])
-                                                        None
-                                                    <case>
-                                                      pattern (shortcut_ext_attr.ml[23,554+4]..[23,554+25]) ghost
-                                                        Ppat_extension "foo"
-                                                        pattern (shortcut_ext_attr.ml[23,554+4]..[23,554+25])
+                                                    structure_item (shortcut_ext_attr.ml[17,417+2]..[17,417+22])
+                                                      Pstr_eval
+                                                      expression (shortcut_ext_attr.ml[17,417+2]..[17,417+22])
+                                                        attribute "foo"
+                                                          []
+                                                        Pexp_object
+                                                        class_structure
+                                                          pattern (shortcut_ext_attr.ml[17,417+18]..[17,417+18]) ghost
+                                                            Ppat_any
+                                                          []
+                                                  ]
+                                                expression (shortcut_ext_attr.ml[18,442+2]..[24,570+31])
+                                                  Pexp_sequence
+                                                  expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23]) ghost
+                                                    Pexp_extension "foo"
+                                                    [
+                                                      structure_item (shortcut_ext_attr.ml[18,442+2]..[18,442+23])
+                                                        Pstr_eval
+                                                        expression (shortcut_ext_attr.ml[18,442+2]..[18,442+23])
                                                           attribute "foo"
                                                             []
-                                                          Ppat_exception
-                                                          pattern (shortcut_ext_attr.ml[23,554+24]..[23,554+25])
-                                                            Ppat_var "x" (shortcut_ext_attr.ml[23,554+24]..[23,554+25])
-                                                      expression (shortcut_ext_attr.ml[23,554+29]..[23,554+31])
-                                                        Pexp_construct "()" (shortcut_ext_attr.ml[23,554+29]..[23,554+31])
-                                                        None
-                                                  ]
-                                            ]
+                                                          Pexp_constant PConst_int (3,None)
+                                                    ]
+                                                  expression (shortcut_ext_attr.ml[19,468+2]..[24,570+31])
+                                                    Pexp_sequence
+                                                    expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17]) ghost
+                                                      Pexp_extension "foo"
+                                                      [
+                                                        structure_item (shortcut_ext_attr.ml[19,468+2]..[19,468+17])
+                                                          Pstr_eval
+                                                          expression (shortcut_ext_attr.ml[19,468+2]..[19,468+17])
+                                                            attribute "foo"
+                                                              []
+                                                            Pexp_new "x" (shortcut_ext_attr.ml[19,468+16]..[19,468+17])
+                                                      ]
+                                                    expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31]) ghost
+                                                      Pexp_extension "foo"
+                                                      [
+                                                        structure_item (shortcut_ext_attr.ml[21,489+2]..[24,570+31])
+                                                          Pstr_eval
+                                                          expression (shortcut_ext_attr.ml[21,489+2]..[24,570+31])
+                                                            attribute "foo"
+                                                              []
+                                                            Pexp_match
+                                                            expression (shortcut_ext_attr.ml[21,489+18]..[21,489+20])
+                                                              Pexp_construct "()" (shortcut_ext_attr.ml[21,489+18]..[21,489+20])
+                                                              None
+                                                            [
+                                                              <case>
+                                                                pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20]) ghost
+                                                                  Ppat_extension "foo"
+                                                                  pattern (shortcut_ext_attr.ml[23,543+4]..[23,543+20])
+                                                                    attribute "foo"
+                                                                      []
+                                                                    Ppat_lazy
+                                                                    pattern (shortcut_ext_attr.ml[23,543+19]..[23,543+20])
+                                                                      Ppat_var "x" (shortcut_ext_attr.ml[23,543+19]..[23,543+20])
+                                                                expression (shortcut_ext_attr.ml[23,543+24]..[23,543+26])
+                                                                  Pexp_construct "()" (shortcut_ext_attr.ml[23,543+24]..[23,543+26])
+                                                                  None
+                                                              <case>
+                                                                pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25]) ghost
+                                                                  Ppat_extension "foo"
+                                                                  pattern (shortcut_ext_attr.ml[24,570+4]..[24,570+25])
+                                                                    attribute "foo"
+                                                                      []
+                                                                    Ppat_exception
+                                                                    pattern (shortcut_ext_attr.ml[24,570+24]..[24,570+25])
+                                                                      Ppat_var "x" (shortcut_ext_attr.ml[24,570+24]..[24,570+25])
+                                                                expression (shortcut_ext_attr.ml[24,570+29]..[24,570+31])
+                                                                  Pexp_construct "()" (shortcut_ext_attr.ml[24,570+29]..[24,570+31])
+                                                                  None
+                                                            ]
+                                                      ]
+                                  ]
           ]
     ]
-  structure_item (shortcut_ext_attr.ml[27,612+0]..[39,882+5])
+  structure_item (shortcut_ext_attr.ml[28,628+0]..[40,898+5])
     Pstr_class
     [
-      class_declaration (shortcut_ext_attr.ml[27,612+0]..[39,882+5])
+      class_declaration (shortcut_ext_attr.ml[28,628+0]..[40,898+5])
         pci_virt = Concrete
         pci_params =
           []
-        pci_name = "x" (shortcut_ext_attr.ml[27,612+6]..[27,612+7])
+        pci_name = "x" (shortcut_ext_attr.ml[28,628+6]..[28,628+7])
         pci_expr =
-          class_expr (shortcut_ext_attr.ml[28,622+12]..[39,882+5])
+          class_expr (shortcut_ext_attr.ml[29,638+12]..[40,898+5])
             attribute "foo"
               []
             Pcl_fun
             Nolabel
             None
-            pattern (shortcut_ext_attr.ml[28,622+12]..[28,622+13])
-              Ppat_var "x" (shortcut_ext_attr.ml[28,622+12]..[28,622+13])
-            class_expr (shortcut_ext_attr.ml[29,639+2]..[39,882+5])
+            pattern (shortcut_ext_attr.ml[29,638+12]..[29,638+13])
+              Ppat_var "x" (shortcut_ext_attr.ml[29,638+12]..[29,638+13])
+            class_expr (shortcut_ext_attr.ml[30,655+2]..[40,898+5])
               Pcl_let Nonrec
               [
                 <def>
                     attribute "foo"
                       []
-                  pattern (shortcut_ext_attr.ml[29,639+12]..[29,639+13])
-                    Ppat_var "x" (shortcut_ext_attr.ml[29,639+12]..[29,639+13])
-                  expression (shortcut_ext_attr.ml[29,639+16]..[29,639+17])
+                  pattern (shortcut_ext_attr.ml[30,655+12]..[30,655+13])
+                    Ppat_var "x" (shortcut_ext_attr.ml[30,655+12]..[30,655+13])
+                  expression (shortcut_ext_attr.ml[30,655+16]..[30,655+17])
                     Pexp_constant PConst_int (3,None)
               ]
-              class_expr (shortcut_ext_attr.ml[30,660+2]..[39,882+5])
+              class_expr (shortcut_ext_attr.ml[31,676+2]..[40,898+5])
                 attribute "foo"
                   []
                 Pcl_structure
                 class_structure
-                  pattern (shortcut_ext_attr.ml[30,660+14]..[30,660+14]) ghost
+                  pattern (shortcut_ext_attr.ml[31,676+14]..[31,676+14]) ghost
                     Ppat_any
                   [
-                    class_field (shortcut_ext_attr.ml[31,675+4]..[31,675+19])
+                    class_field (shortcut_ext_attr.ml[32,691+4]..[32,691+19])
                         attribute "foo"
                           []
                       Pcf_inherit Fresh
-                        class_expr (shortcut_ext_attr.ml[31,675+18]..[31,675+19])
-                          Pcl_constr "x" (shortcut_ext_attr.ml[31,675+18]..[31,675+19])
+                        class_expr (shortcut_ext_attr.ml[32,691+18]..[32,691+19])
+                          Pcl_constr "x" (shortcut_ext_attr.ml[32,691+18]..[32,691+19])
                           []
                         None
-                    class_field (shortcut_ext_attr.ml[32,695+4]..[32,695+19])
+                    class_field (shortcut_ext_attr.ml[33,711+4]..[33,711+19])
                         attribute "foo"
                           []
                       Pcf_val Immutable
-                        "x" (shortcut_ext_attr.ml[32,695+14]..[32,695+15])
+                        "x" (shortcut_ext_attr.ml[33,711+14]..[33,711+15])
                         Concrete Fresh
-                        expression (shortcut_ext_attr.ml[32,695+18]..[32,695+19])
+                        expression (shortcut_ext_attr.ml[33,711+18]..[33,711+19])
                           Pexp_constant PConst_int (3,None)
-                    class_field (shortcut_ext_attr.ml[33,715+4]..[33,715+27])
+                    class_field (shortcut_ext_attr.ml[34,731+4]..[34,731+27])
                         attribute "foo"
                           []
                       Pcf_val Immutable
-                        "x" (shortcut_ext_attr.ml[33,715+22]..[33,715+23])
+                        "x" (shortcut_ext_attr.ml[34,731+22]..[34,731+23])
                         Virtual
-                        core_type (shortcut_ext_attr.ml[33,715+26]..[33,715+27])
-                          Ptyp_constr "t" (shortcut_ext_attr.ml[33,715+26]..[33,715+27])
+                        core_type (shortcut_ext_attr.ml[34,731+26]..[34,731+27])
+                          Ptyp_constr "t" (shortcut_ext_attr.ml[34,731+26]..[34,731+27])
                           []
-                    class_field (shortcut_ext_attr.ml[34,743+4]..[34,743+28])
+                    class_field (shortcut_ext_attr.ml[35,759+4]..[35,759+28])
                         attribute "foo"
                           []
                       Pcf_val Mutable
-                        "x" (shortcut_ext_attr.ml[34,743+23]..[34,743+24])
+                        "x" (shortcut_ext_attr.ml[35,759+23]..[35,759+24])
                         Concrete Override
-                        expression (shortcut_ext_attr.ml[34,743+27]..[34,743+28])
+                        expression (shortcut_ext_attr.ml[35,759+27]..[35,759+28])
                           Pexp_constant PConst_int (3,None)
-                    class_field (shortcut_ext_attr.ml[35,772+4]..[35,772+22])
+                    class_field (shortcut_ext_attr.ml[36,788+4]..[36,788+22])
                         attribute "foo"
                           []
                       Pcf_method Public
-                        "x" (shortcut_ext_attr.ml[35,772+17]..[35,772+18])
+                        "x" (shortcut_ext_attr.ml[36,788+17]..[36,788+18])
                         Concrete Fresh
-                        expression (shortcut_ext_attr.ml[35,772+10]..[35,772+22]) ghost
+                        expression (shortcut_ext_attr.ml[36,788+10]..[36,788+22]) ghost
                           Pexp_poly
-                          expression (shortcut_ext_attr.ml[35,772+21]..[35,772+22])
+                          expression (shortcut_ext_attr.ml[36,788+21]..[36,788+22])
                             Pexp_constant PConst_int (3,None)
                           None
-                    class_field (shortcut_ext_attr.ml[36,795+4]..[36,795+30])
+                    class_field (shortcut_ext_attr.ml[37,811+4]..[37,811+30])
                         attribute "foo"
                           []
                       Pcf_method Public
-                        "x" (shortcut_ext_attr.ml[36,795+25]..[36,795+26])
+                        "x" (shortcut_ext_attr.ml[37,811+25]..[37,811+26])
                         Virtual
-                        core_type (shortcut_ext_attr.ml[36,795+29]..[36,795+30])
-                          Ptyp_constr "t" (shortcut_ext_attr.ml[36,795+29]..[36,795+30])
+                        core_type (shortcut_ext_attr.ml[37,811+29]..[37,811+30])
+                          Ptyp_constr "t" (shortcut_ext_attr.ml[37,811+29]..[37,811+30])
                           []
-                    class_field (shortcut_ext_attr.ml[37,826+4]..[37,826+31])
+                    class_field (shortcut_ext_attr.ml[38,842+4]..[38,842+31])
                         attribute "foo"
                           []
                       Pcf_method Private
-                        "x" (shortcut_ext_attr.ml[37,826+26]..[37,826+27])
+                        "x" (shortcut_ext_attr.ml[38,842+26]..[38,842+27])
                         Concrete Override
-                        expression (shortcut_ext_attr.ml[37,826+10]..[37,826+31]) ghost
+                        expression (shortcut_ext_attr.ml[38,842+10]..[38,842+31]) ghost
                           Pexp_poly
-                          expression (shortcut_ext_attr.ml[37,826+30]..[37,826+31])
+                          expression (shortcut_ext_attr.ml[38,842+30]..[38,842+31])
                             Pexp_constant PConst_int (3,None)
                           None
-                    class_field (shortcut_ext_attr.ml[38,858+4]..[38,858+23])
+                    class_field (shortcut_ext_attr.ml[39,874+4]..[39,874+23])
                         attribute "foo"
                           []
                       Pcf_initializer
-                        expression (shortcut_ext_attr.ml[38,858+22]..[38,858+23])
-                          Pexp_ident "x" (shortcut_ext_attr.ml[38,858+22]..[38,858+23])
+                        expression (shortcut_ext_attr.ml[39,874+22]..[39,874+23])
+                          Pexp_ident "x" (shortcut_ext_attr.ml[39,874+22]..[39,874+23])
                   ]
     ]
-  structure_item (shortcut_ext_attr.ml[42,918+0]..[50,1098+5])
+  structure_item (shortcut_ext_attr.ml[43,934+0]..[51,1114+5])
     Pstr_class_type
     [
-      class_type_declaration (shortcut_ext_attr.ml[42,918+0]..[50,1098+5])
+      class_type_declaration (shortcut_ext_attr.ml[43,934+0]..[51,1114+5])
         pci_virt = Concrete
         pci_params =
           []
-        pci_name = "t" (shortcut_ext_attr.ml[42,918+11]..[42,918+12])
+        pci_name = "t" (shortcut_ext_attr.ml[43,934+11]..[43,934+12])
         pci_expr =
-          class_type (shortcut_ext_attr.ml[43,933+2]..[50,1098+5])
+          class_type (shortcut_ext_attr.ml[44,949+2]..[51,1114+5])
             attribute "foo"
               []
             Pcty_signature
             class_signature
-              core_type (shortcut_ext_attr.ml[43,933+14]..[43,933+14])
+              core_type (shortcut_ext_attr.ml[44,949+14]..[44,949+14])
                 Ptyp_any
               [
-                class_type_field (shortcut_ext_attr.ml[44,948+4]..[44,948+19])
+                class_type_field (shortcut_ext_attr.ml[45,964+4]..[45,964+19])
                     attribute "foo"
                       []
                   Pctf_inherit
-                  class_type (shortcut_ext_attr.ml[44,948+18]..[44,948+19])
-                    Pcty_constr "t" (shortcut_ext_attr.ml[44,948+18]..[44,948+19])
+                  class_type (shortcut_ext_attr.ml[45,964+18]..[45,964+19])
+                    Pcty_constr "t" (shortcut_ext_attr.ml[45,964+18]..[45,964+19])
                     []
-                class_type_field (shortcut_ext_attr.ml[45,968+4]..[45,968+19])
+                class_type_field (shortcut_ext_attr.ml[46,984+4]..[46,984+19])
                     attribute "foo"
                       []
                   Pctf_val "x" Immutable Concrete
-                    core_type (shortcut_ext_attr.ml[45,968+18]..[45,968+19])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[45,968+18]..[45,968+19])
+                    core_type (shortcut_ext_attr.ml[46,984+18]..[46,984+19])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[46,984+18]..[46,984+19])
                       []
-                class_type_field (shortcut_ext_attr.ml[46,988+4]..[46,988+27])
+                class_type_field (shortcut_ext_attr.ml[47,1004+4]..[47,1004+27])
                     attribute "foo"
                       []
                   Pctf_val "x" Mutable Concrete
-                    core_type (shortcut_ext_attr.ml[46,988+26]..[46,988+27])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[46,988+26]..[46,988+27])
+                    core_type (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[47,1004+26]..[47,1004+27])
                       []
-                class_type_field (shortcut_ext_attr.ml[47,1016+4]..[47,1016+22])
+                class_type_field (shortcut_ext_attr.ml[48,1032+4]..[48,1032+22])
                     attribute "foo"
                       []
                   Pctf_method "x" Public Concrete
-                    core_type (shortcut_ext_attr.ml[47,1016+21]..[47,1016+22])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[47,1016+21]..[47,1016+22])
+                    core_type (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[48,1032+21]..[48,1032+22])
                       []
-                class_type_field (shortcut_ext_attr.ml[48,1039+4]..[48,1039+30])
+                class_type_field (shortcut_ext_attr.ml[49,1055+4]..[49,1055+30])
                     attribute "foo"
                       []
                   Pctf_method "x" Private Concrete
-                    core_type (shortcut_ext_attr.ml[48,1039+29]..[48,1039+30])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[48,1039+29]..[48,1039+30])
+                    core_type (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[49,1055+29]..[49,1055+30])
                       []
-                class_type_field (shortcut_ext_attr.ml[49,1070+4]..[49,1070+27])
+                class_type_field (shortcut_ext_attr.ml[50,1086+4]..[50,1086+27])
                     attribute "foo"
                       []
                   Pctf_constraint
-                    core_type (shortcut_ext_attr.ml[49,1070+21]..[49,1070+22])
-                      Ptyp_constr "t" (shortcut_ext_attr.ml[49,1070+21]..[49,1070+22])
+                    core_type (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22])
+                      Ptyp_constr "t" (shortcut_ext_attr.ml[50,1086+21]..[50,1086+22])
                       []
-                    core_type (shortcut_ext_attr.ml[49,1070+25]..[49,1070+27])
-                      Ptyp_constr "t'" (shortcut_ext_attr.ml[49,1070+25]..[49,1070+27])
+                    core_type (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27])
+                      Ptyp_constr "t'" (shortcut_ext_attr.ml[50,1086+25]..[50,1086+27])
                       []
               ]
     ]
-  structure_item (shortcut_ext_attr.ml[53,1128+0]..[54,1137+22])
+  structure_item (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22])
     Pstr_type Rec
     [
-      type_declaration "t" (shortcut_ext_attr.ml[53,1128+5]..[53,1128+6]) (shortcut_ext_attr.ml[53,1128+0]..[54,1137+22])
+      type_declaration "t" (shortcut_ext_attr.ml[54,1144+5]..[54,1144+6]) (shortcut_ext_attr.ml[54,1144+0]..[55,1153+22])
         ptype_params =
           []
         ptype_cstrs =
@@ -481,86 +497,86 @@
         ptype_private = Public
         ptype_manifest =
           Some
-            core_type (shortcut_ext_attr.ml[54,1137+2]..[54,1137+22]) ghost
+            core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22]) ghost
               Ptyp_extension "foo"
-              core_type (shortcut_ext_attr.ml[54,1137+2]..[54,1137+22])
+              core_type (shortcut_ext_attr.ml[55,1153+2]..[55,1153+22])
                 attribute "foo"
                   []
-                Ptyp_package "M" (shortcut_ext_attr.ml[54,1137+20]..[54,1137+21])
+                Ptyp_package "M" (shortcut_ext_attr.ml[55,1153+20]..[55,1153+21])
                 []
     ]
-  structure_item (shortcut_ext_attr.ml[57,1186+0]..[60,1242+22])
+  structure_item (shortcut_ext_attr.ml[58,1202+0]..[61,1258+22])
     Pstr_module
-    "M" (shortcut_ext_attr.ml[57,1186+7]..[57,1186+8])
-      module_expr (shortcut_ext_attr.ml[58,1197+2]..[60,1242+22])
+    "M" (shortcut_ext_attr.ml[58,1202+7]..[58,1202+8])
+      module_expr (shortcut_ext_attr.ml[59,1213+2]..[61,1258+22])
         attribute "foo"
           []
-        Pmod_functor "M" (shortcut_ext_attr.ml[58,1197+17]..[58,1197+18])
-        module_type (shortcut_ext_attr.ml[58,1197+21]..[58,1197+22])
-          Pmty_ident "S" (shortcut_ext_attr.ml[58,1197+21]..[58,1197+22])
-        module_expr (shortcut_ext_attr.ml[59,1224+4]..[60,1242+22])
+        Pmod_functor "M" (shortcut_ext_attr.ml[59,1213+17]..[59,1213+18])
+        module_type (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22])
+          Pmty_ident "S" (shortcut_ext_attr.ml[59,1213+21]..[59,1213+22])
+        module_expr (shortcut_ext_attr.ml[60,1240+4]..[61,1258+22])
           Pmod_apply
-          module_expr (shortcut_ext_attr.ml[59,1224+4]..[59,1224+17])
+          module_expr (shortcut_ext_attr.ml[60,1240+4]..[60,1240+17])
             attribute "foo"
               []
             Pmod_unpack
-            expression (shortcut_ext_attr.ml[59,1224+15]..[59,1224+16])
-              Pexp_ident "x" (shortcut_ext_attr.ml[59,1224+15]..[59,1224+16])
-          module_expr (shortcut_ext_attr.ml[60,1242+5]..[60,1242+21])
+            expression (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16])
+              Pexp_ident "x" (shortcut_ext_attr.ml[60,1240+15]..[60,1240+16])
+          module_expr (shortcut_ext_attr.ml[61,1258+5]..[61,1258+21])
             attribute "foo"
               []
             Pmod_structure
             []
-  structure_item (shortcut_ext_attr.ml[63,1295+0]..[66,1368+19])
-    Pstr_modtype "S" (shortcut_ext_attr.ml[63,1295+12]..[63,1295+13])
-      module_type (shortcut_ext_attr.ml[64,1311+2]..[66,1368+19])
+  structure_item (shortcut_ext_attr.ml[64,1311+0]..[67,1384+19])
+    Pstr_modtype "S" (shortcut_ext_attr.ml[64,1311+12]..[64,1311+13])
+      module_type (shortcut_ext_attr.ml[65,1327+2]..[67,1384+19])
         attribute "foo"
           []
-        Pmty_functor "M" (shortcut_ext_attr.ml[64,1311+17]..[64,1311+18])
-        module_type (shortcut_ext_attr.ml[64,1311+19]..[64,1311+20])
-          Pmty_ident "S" (shortcut_ext_attr.ml[64,1311+19]..[64,1311+20])
-        module_type (shortcut_ext_attr.ml[65,1336+4]..[66,1368+19])
+        Pmty_functor "M" (shortcut_ext_attr.ml[65,1327+17]..[65,1327+18])
+        module_type (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20])
+          Pmty_ident "S" (shortcut_ext_attr.ml[65,1327+19]..[65,1327+20])
+        module_type (shortcut_ext_attr.ml[66,1352+4]..[67,1384+19])
           Pmty_functor "_" (_none_[1,0+-1]..[1,0+-1]) ghost
-          module_type (shortcut_ext_attr.ml[65,1336+5]..[65,1336+27])
+          module_type (shortcut_ext_attr.ml[66,1352+5]..[66,1352+27])
             attribute "foo"
               []
             Pmty_typeof
-            module_expr (shortcut_ext_attr.ml[65,1336+26]..[65,1336+27])
-              Pmod_ident "M" (shortcut_ext_attr.ml[65,1336+26]..[65,1336+27])
-          module_type (shortcut_ext_attr.ml[66,1368+5]..[66,1368+18])
+            module_expr (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27])
+              Pmod_ident "M" (shortcut_ext_attr.ml[66,1352+26]..[66,1352+27])
+          module_type (shortcut_ext_attr.ml[67,1384+5]..[67,1384+18])
             attribute "foo"
               []
             Pmty_signature
             []
-  structure_item (shortcut_ext_attr.ml[69,1411+0]..[70,1431+15]) ghost
+  structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[69,1411+0]..[70,1431+15])
+      structure_item (shortcut_ext_attr.ml[70,1427+0]..[71,1447+15])
         Pstr_value Nonrec
         [
           <def>
               attribute "foo"
                 []
-            pattern (shortcut_ext_attr.ml[69,1411+14]..[69,1411+15])
-              Ppat_var "x" (shortcut_ext_attr.ml[69,1411+14]..[69,1411+15])
-            expression (shortcut_ext_attr.ml[69,1411+18]..[69,1411+19])
+            pattern (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15])
+              Ppat_var "x" (shortcut_ext_attr.ml[70,1427+14]..[70,1427+15])
+            expression (shortcut_ext_attr.ml[70,1427+18]..[70,1427+19])
               Pexp_constant PConst_int (4,None)
           <def>
               attribute "foo"
                 []
-            pattern (shortcut_ext_attr.ml[70,1431+10]..[70,1431+11])
-              Ppat_var "y" (shortcut_ext_attr.ml[70,1431+10]..[70,1431+11])
-            expression (shortcut_ext_attr.ml[70,1431+14]..[70,1431+15])
-              Pexp_ident "x" (shortcut_ext_attr.ml[70,1431+14]..[70,1431+15])
+            pattern (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11])
+              Ppat_var "y" (shortcut_ext_attr.ml[71,1447+10]..[71,1447+11])
+            expression (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15])
+              Pexp_ident "x" (shortcut_ext_attr.ml[71,1447+14]..[71,1447+15])
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[72,1448+0]..[73,1471+17]) ghost
+  structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[72,1448+0]..[73,1471+17])
+      structure_item (shortcut_ext_attr.ml[73,1464+0]..[74,1487+17])
         Pstr_type Rec
         [
-          type_declaration "t" (shortcut_ext_attr.ml[72,1448+15]..[72,1448+16]) (shortcut_ext_attr.ml[72,1448+0]..[72,1448+22])
+          type_declaration "t" (shortcut_ext_attr.ml[73,1464+15]..[73,1464+16]) (shortcut_ext_attr.ml[73,1464+0]..[73,1464+22])
             attribute "foo"
               []
             ptype_params =
@@ -572,10 +588,10 @@
             ptype_private = Public
             ptype_manifest =
               Some
-                core_type (shortcut_ext_attr.ml[72,1448+19]..[72,1448+22])
-                  Ptyp_constr "int" (shortcut_ext_attr.ml[72,1448+19]..[72,1448+22])
+                core_type (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22])
+                  Ptyp_constr "int" (shortcut_ext_attr.ml[73,1464+19]..[73,1464+22])
                   []
-          type_declaration "t" (shortcut_ext_attr.ml[73,1471+10]..[73,1471+11]) (shortcut_ext_attr.ml[73,1471+0]..[73,1471+17])
+          type_declaration "t" (shortcut_ext_attr.ml[74,1487+10]..[74,1487+11]) (shortcut_ext_attr.ml[74,1487+0]..[74,1487+17])
             attribute "foo"
               []
             ptype_params =
@@ -587,25 +603,25 @@
             ptype_private = Public
             ptype_manifest =
               Some
-                core_type (shortcut_ext_attr.ml[73,1471+14]..[73,1471+17])
-                  Ptyp_constr "int" (shortcut_ext_attr.ml[73,1471+14]..[73,1471+17])
+                core_type (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17])
+                  Ptyp_constr "int" (shortcut_ext_attr.ml[74,1487+14]..[74,1487+17])
                   []
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[74,1489+0]..[74,1489+21]) ghost
+  structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[74,1489+0]..[74,1489+21])
+      structure_item (shortcut_ext_attr.ml[75,1505+0]..[75,1505+21])
         Pstr_typext
         type_extension
           attribute "foo"
             []
-          ptyext_path = "t" (shortcut_ext_attr.ml[74,1489+15]..[74,1489+16])
+          ptyext_path = "t" (shortcut_ext_attr.ml[75,1505+15]..[75,1505+16])
           ptyext_params =
             []
           ptyext_constructors =
             [
-              extension_constructor (shortcut_ext_attr.ml[74,1489+20]..[74,1489+21])
+              extension_constructor (shortcut_ext_attr.ml[75,1505+20]..[75,1505+21])
                 pext_name = "T"
                 pext_kind =
                   Pext_decl
@@ -614,64 +630,64 @@
             ]
           ptyext_private = Public
     ]
-  structure_item (shortcut_ext_attr.ml[76,1512+0]..[76,1512+21]) ghost
+  structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[76,1512+0]..[76,1512+21])
+      structure_item (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21])
         Pstr_class
         [
-          class_declaration (shortcut_ext_attr.ml[76,1512+0]..[76,1512+21])
+          class_declaration (shortcut_ext_attr.ml[77,1528+0]..[77,1528+21])
             attribute "foo"
               []
             pci_virt = Concrete
             pci_params =
               []
-            pci_name = "x" (shortcut_ext_attr.ml[76,1512+16]..[76,1512+17])
+            pci_name = "x" (shortcut_ext_attr.ml[77,1528+16]..[77,1528+17])
             pci_expr =
-              class_expr (shortcut_ext_attr.ml[76,1512+20]..[76,1512+21])
-                Pcl_constr "x" (shortcut_ext_attr.ml[76,1512+20]..[76,1512+21])
+              class_expr (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21])
+                Pcl_constr "x" (shortcut_ext_attr.ml[77,1528+20]..[77,1528+21])
                 []
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[77,1534+0]..[77,1534+26]) ghost
+  structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[77,1534+0]..[77,1534+26])
+      structure_item (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26])
         Pstr_class_type
         [
-          class_type_declaration (shortcut_ext_attr.ml[77,1534+0]..[77,1534+26])
+          class_type_declaration (shortcut_ext_attr.ml[78,1550+0]..[78,1550+26])
             attribute "foo"
               []
             pci_virt = Concrete
             pci_params =
               []
-            pci_name = "x" (shortcut_ext_attr.ml[77,1534+21]..[77,1534+22])
+            pci_name = "x" (shortcut_ext_attr.ml[78,1550+21]..[78,1550+22])
             pci_expr =
-              class_type (shortcut_ext_attr.ml[77,1534+25]..[77,1534+26])
-                Pcty_constr "x" (shortcut_ext_attr.ml[77,1534+25]..[77,1534+26])
+              class_type (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26])
+                Pcty_constr "x" (shortcut_ext_attr.ml[78,1550+25]..[78,1550+26])
                 []
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[78,1561+0]..[78,1561+30]) ghost
+  structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[78,1561+0]..[78,1561+30])
+      structure_item (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30])
         Pstr_primitive
-        value_description "x" (shortcut_ext_attr.ml[78,1561+19]..[78,1561+20]) (shortcut_ext_attr.ml[78,1561+0]..[78,1561+30])
+        value_description "x" (shortcut_ext_attr.ml[79,1577+19]..[79,1577+20]) (shortcut_ext_attr.ml[79,1577+0]..[79,1577+30])
           attribute "foo"
             []
-          core_type (shortcut_ext_attr.ml[78,1561+23]..[78,1561+24])
+          core_type (shortcut_ext_attr.ml[79,1577+23]..[79,1577+24])
             Ptyp_any
           [
             ""
           ]
     ]
-  structure_item (shortcut_ext_attr.ml[79,1592+0]..[79,1592+21]) ghost
+  structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[79,1592+0]..[79,1592+21])
+      structure_item (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21])
         Pstr_exception
-        extension_constructor (shortcut_ext_attr.ml[79,1592+0]..[79,1592+21])
+        extension_constructor (shortcut_ext_attr.ml[80,1608+0]..[80,1608+21])
           attribute "foo"
             []
           pext_name = "X"
@@ -680,110 +696,110 @@
               []
               None
     ]
-  structure_item (shortcut_ext_attr.ml[81,1615+0]..[81,1615+22]) ghost
+  structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[81,1615+0]..[81,1615+22])
+      structure_item (shortcut_ext_attr.ml[82,1631+0]..[82,1631+22])
         Pstr_module
-        "M" (shortcut_ext_attr.ml[81,1615+17]..[81,1615+18])
+        "M" (shortcut_ext_attr.ml[82,1631+17]..[82,1631+18])
           attribute "foo"
             []
-          module_expr (shortcut_ext_attr.ml[81,1615+21]..[81,1615+22])
-            Pmod_ident "M" (shortcut_ext_attr.ml[81,1615+21]..[81,1615+22])
+          module_expr (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22])
+            Pmod_ident "M" (shortcut_ext_attr.ml[82,1631+21]..[82,1631+22])
     ]
-  structure_item (shortcut_ext_attr.ml[82,1638+0]..[83,1669+19]) ghost
+  structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[82,1638+0]..[83,1669+19])
+      structure_item (shortcut_ext_attr.ml[83,1654+0]..[84,1685+19])
         Pstr_recmodule
         [
-          "M" (shortcut_ext_attr.ml[82,1638+21]..[82,1638+22])
+          "M" (shortcut_ext_attr.ml[83,1654+21]..[83,1654+22])
             attribute "foo"
               []
-            module_expr (shortcut_ext_attr.ml[82,1638+23]..[82,1638+30])
+            module_expr (shortcut_ext_attr.ml[83,1654+23]..[83,1654+30])
               Pmod_constraint
-              module_expr (shortcut_ext_attr.ml[82,1638+29]..[82,1638+30])
-                Pmod_ident "M" (shortcut_ext_attr.ml[82,1638+29]..[82,1638+30])
-              module_type (shortcut_ext_attr.ml[82,1638+25]..[82,1638+26])
-                Pmty_ident "S" (shortcut_ext_attr.ml[82,1638+25]..[82,1638+26])
-          "M" (shortcut_ext_attr.ml[83,1669+10]..[83,1669+11])
+              module_expr (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30])
+                Pmod_ident "M" (shortcut_ext_attr.ml[83,1654+29]..[83,1654+30])
+              module_type (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26])
+                Pmty_ident "S" (shortcut_ext_attr.ml[83,1654+25]..[83,1654+26])
+          "M" (shortcut_ext_attr.ml[84,1685+10]..[84,1685+11])
             attribute "foo"
               []
-            module_expr (shortcut_ext_attr.ml[83,1669+12]..[83,1669+19])
+            module_expr (shortcut_ext_attr.ml[84,1685+12]..[84,1685+19])
               Pmod_constraint
-              module_expr (shortcut_ext_attr.ml[83,1669+18]..[83,1669+19])
-                Pmod_ident "M" (shortcut_ext_attr.ml[83,1669+18]..[83,1669+19])
-              module_type (shortcut_ext_attr.ml[83,1669+14]..[83,1669+15])
-                Pmty_ident "S" (shortcut_ext_attr.ml[83,1669+14]..[83,1669+15])
+              module_expr (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19])
+                Pmod_ident "M" (shortcut_ext_attr.ml[84,1685+18]..[84,1685+19])
+              module_type (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15])
+                Pmty_ident "S" (shortcut_ext_attr.ml[84,1685+14]..[84,1685+15])
         ]
     ]
-  structure_item (shortcut_ext_attr.ml[84,1689+0]..[84,1689+27]) ghost
+  structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[84,1689+0]..[84,1689+27])
-        Pstr_modtype "S" (shortcut_ext_attr.ml[84,1689+22]..[84,1689+23])
+      structure_item (shortcut_ext_attr.ml[85,1705+0]..[85,1705+27])
+        Pstr_modtype "S" (shortcut_ext_attr.ml[85,1705+22]..[85,1705+23])
           attribute "foo"
             []
-          module_type (shortcut_ext_attr.ml[84,1689+26]..[84,1689+27])
-            Pmty_ident "S" (shortcut_ext_attr.ml[84,1689+26]..[84,1689+27])
+          module_type (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27])
+            Pmty_ident "S" (shortcut_ext_attr.ml[85,1705+26]..[85,1705+27])
     ]
-  structure_item (shortcut_ext_attr.ml[86,1718+0]..[86,1718+19]) ghost
+  structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[86,1718+0]..[86,1718+19])
+      structure_item (shortcut_ext_attr.ml[87,1734+0]..[87,1734+19])
         Pstr_include          attribute "foo"
             []
-        module_expr (shortcut_ext_attr.ml[86,1718+18]..[86,1718+19])
-          Pmod_ident "M" (shortcut_ext_attr.ml[86,1718+18]..[86,1718+19])
+        module_expr (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19])
+          Pmod_ident "M" (shortcut_ext_attr.ml[87,1734+18]..[87,1734+19])
     ]
-  structure_item (shortcut_ext_attr.ml[87,1738+0]..[87,1738+16]) ghost
+  structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16]) ghost
     Pstr_extension "foo"
     [
-      structure_item (shortcut_ext_attr.ml[87,1738+0]..[87,1738+16])
-        Pstr_open Fresh "M" (shortcut_ext_attr.ml[87,1738+15]..[87,1738+16])
+      structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16])
+        Pstr_open Fresh "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16])
           attribute "foo"
             []
     ]
-  structure_item (shortcut_ext_attr.ml[90,1778+0]..[113,2174+3])
-    Pstr_modtype "S" (shortcut_ext_attr.ml[90,1778+12]..[90,1778+13])
-      module_type (shortcut_ext_attr.ml[90,1778+16]..[113,2174+3])
+  structure_item (shortcut_ext_attr.ml[91,1794+0]..[114,2190+3])
+    Pstr_modtype "S" (shortcut_ext_attr.ml[91,1794+12]..[91,1794+13])
+      module_type (shortcut_ext_attr.ml[91,1794+16]..[114,2190+3])
         Pmty_signature
         [
-          signature_item (shortcut_ext_attr.ml[91,1798+2]..[91,1798+21]) ghost
+          signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[91,1798+2]..[91,1798+21])
+              signature_item (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21])
                 Psig_value
-                value_description "x" (shortcut_ext_attr.ml[91,1798+16]..[91,1798+17]) (shortcut_ext_attr.ml[91,1798+2]..[91,1798+21])
+                value_description "x" (shortcut_ext_attr.ml[92,1814+16]..[92,1814+17]) (shortcut_ext_attr.ml[92,1814+2]..[92,1814+21])
                   attribute "foo"
                     []
-                  core_type (shortcut_ext_attr.ml[91,1798+20]..[91,1798+21])
-                    Ptyp_constr "t" (shortcut_ext_attr.ml[91,1798+20]..[91,1798+21])
+                  core_type (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21])
+                    Ptyp_constr "t" (shortcut_ext_attr.ml[92,1814+20]..[92,1814+21])
                     []
                   []
             ]
-          signature_item (shortcut_ext_attr.ml[92,1820+2]..[92,1820+31]) ghost
+          signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[92,1820+2]..[92,1820+31])
+              signature_item (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31])
                 Psig_value
-                value_description "x" (shortcut_ext_attr.ml[92,1820+21]..[92,1820+22]) (shortcut_ext_attr.ml[92,1820+2]..[92,1820+31])
+                value_description "x" (shortcut_ext_attr.ml[93,1836+21]..[93,1836+22]) (shortcut_ext_attr.ml[93,1836+2]..[93,1836+31])
                   attribute "foo"
                     []
-                  core_type (shortcut_ext_attr.ml[92,1820+25]..[92,1820+26])
-                    Ptyp_constr "t" (shortcut_ext_attr.ml[92,1820+25]..[92,1820+26])
+                  core_type (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26])
+                    Ptyp_constr "t" (shortcut_ext_attr.ml[93,1836+25]..[93,1836+26])
                     []
                   [
                     ""
                   ]
             ]
-          signature_item (shortcut_ext_attr.ml[94,1853+2]..[95,1878+20]) ghost
+          signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[94,1853+2]..[95,1878+20])
+              signature_item (shortcut_ext_attr.ml[95,1869+2]..[96,1894+20])
                 Psig_type Rec
                 [
-                  type_declaration "t" (shortcut_ext_attr.ml[94,1853+17]..[94,1853+18]) (shortcut_ext_attr.ml[94,1853+2]..[94,1853+24])
+                  type_declaration "t" (shortcut_ext_attr.ml[95,1869+17]..[95,1869+18]) (shortcut_ext_attr.ml[95,1869+2]..[95,1869+24])
                     attribute "foo"
                       []
                     ptype_params =
@@ -795,10 +811,10 @@
                     ptype_private = Public
                     ptype_manifest =
                       Some
-                        core_type (shortcut_ext_attr.ml[94,1853+21]..[94,1853+24])
-                          Ptyp_constr "int" (shortcut_ext_attr.ml[94,1853+21]..[94,1853+24])
+                        core_type (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24])
+                          Ptyp_constr "int" (shortcut_ext_attr.ml[95,1869+21]..[95,1869+24])
                           []
-                  type_declaration "t'" (shortcut_ext_attr.ml[95,1878+12]..[95,1878+14]) (shortcut_ext_attr.ml[95,1878+2]..[95,1878+20])
+                  type_declaration "t'" (shortcut_ext_attr.ml[96,1894+12]..[96,1894+14]) (shortcut_ext_attr.ml[96,1894+2]..[96,1894+20])
                     attribute "foo"
                       []
                     ptype_params =
@@ -810,25 +826,25 @@
                     ptype_private = Public
                     ptype_manifest =
                       Some
-                        core_type (shortcut_ext_attr.ml[95,1878+17]..[95,1878+20])
-                          Ptyp_constr "int" (shortcut_ext_attr.ml[95,1878+17]..[95,1878+20])
+                        core_type (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20])
+                          Ptyp_constr "int" (shortcut_ext_attr.ml[96,1894+17]..[96,1894+20])
                           []
                 ]
             ]
-          signature_item (shortcut_ext_attr.ml[96,1899+2]..[96,1899+23]) ghost
+          signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[96,1899+2]..[96,1899+23])
+              signature_item (shortcut_ext_attr.ml[97,1915+2]..[97,1915+23])
                 Psig_typext
                 type_extension
                   attribute "foo"
                     []
-                  ptyext_path = "t" (shortcut_ext_attr.ml[96,1899+17]..[96,1899+18])
+                  ptyext_path = "t" (shortcut_ext_attr.ml[97,1915+17]..[97,1915+18])
                   ptyext_params =
                     []
                   ptyext_constructors =
                     [
-                      extension_constructor (shortcut_ext_attr.ml[96,1899+22]..[96,1899+23])
+                      extension_constructor (shortcut_ext_attr.ml[97,1915+22]..[97,1915+23])
                         pext_name = "T"
                         pext_kind =
                           Pext_decl
@@ -837,12 +853,12 @@
                     ]
                   ptyext_private = Public
             ]
-          signature_item (shortcut_ext_attr.ml[98,1924+2]..[98,1924+23]) ghost
+          signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[98,1924+2]..[98,1924+23])
+              signature_item (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23])
                 Psig_exception
-                extension_constructor (shortcut_ext_attr.ml[98,1924+2]..[98,1924+23])
+                extension_constructor (shortcut_ext_attr.ml[99,1940+2]..[99,1940+23])
                   attribute "foo"
                     []
                   pext_name = "X"
@@ -851,107 +867,107 @@
                       []
                       None
             ]
-          signature_item (shortcut_ext_attr.ml[100,1949+2]..[100,1949+24]) ghost
+          signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[100,1949+2]..[100,1949+24])
-                Psig_module "M" (shortcut_ext_attr.ml[100,1949+19]..[100,1949+20])
+              signature_item (shortcut_ext_attr.ml[101,1965+2]..[101,1965+24])
+                Psig_module "M" (shortcut_ext_attr.ml[101,1965+19]..[101,1965+20])
                   attribute "foo"
                     []
-                module_type (shortcut_ext_attr.ml[100,1949+23]..[100,1949+24])
-                  Pmty_ident "S" (shortcut_ext_attr.ml[100,1949+23]..[100,1949+24])
+                module_type (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24])
+                  Pmty_ident "S" (shortcut_ext_attr.ml[101,1965+23]..[101,1965+24])
             ]
-          signature_item (shortcut_ext_attr.ml[101,1974+2]..[102,2003+17]) ghost
+          signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[101,1974+2]..[102,2003+17])
+              signature_item (shortcut_ext_attr.ml[102,1990+2]..[103,2019+17])
                 Psig_recmodule
                 [
-                  "M" (shortcut_ext_attr.ml[101,1974+23]..[101,1974+24])
+                  "M" (shortcut_ext_attr.ml[102,1990+23]..[102,1990+24])
                     attribute "foo"
                       []
-                    module_type (shortcut_ext_attr.ml[101,1974+27]..[101,1974+28])
-                      Pmty_ident "S" (shortcut_ext_attr.ml[101,1974+27]..[101,1974+28])
-                  "M" (shortcut_ext_attr.ml[102,2003+12]..[102,2003+13])
+                    module_type (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28])
+                      Pmty_ident "S" (shortcut_ext_attr.ml[102,1990+27]..[102,1990+28])
+                  "M" (shortcut_ext_attr.ml[103,2019+12]..[103,2019+13])
                     attribute "foo"
                       []
-                    module_type (shortcut_ext_attr.ml[102,2003+16]..[102,2003+17])
-                      Pmty_ident "S" (shortcut_ext_attr.ml[102,2003+16]..[102,2003+17])
+                    module_type (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17])
+                      Pmty_ident "S" (shortcut_ext_attr.ml[103,2019+16]..[103,2019+17])
                 ]
             ]
-          signature_item (shortcut_ext_attr.ml[103,2021+2]..[103,2021+24]) ghost
+          signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[103,2021+2]..[103,2021+24])
-                Psig_module "M" (shortcut_ext_attr.ml[103,2021+19]..[103,2021+20])
+              signature_item (shortcut_ext_attr.ml[104,2037+2]..[104,2037+24])
+                Psig_module "M" (shortcut_ext_attr.ml[104,2037+19]..[104,2037+20])
                   attribute "foo"
                     []
-                module_type (shortcut_ext_attr.ml[103,2021+23]..[103,2021+24])
-                  Pmty_alias "M" (shortcut_ext_attr.ml[103,2021+23]..[103,2021+24])
+                module_type (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24])
+                  Pmty_alias "M" (shortcut_ext_attr.ml[104,2037+23]..[104,2037+24])
             ]
-          signature_item (shortcut_ext_attr.ml[105,2047+2]..[105,2047+29]) ghost
+          signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[105,2047+2]..[105,2047+29])
-                Psig_modtype "S" (shortcut_ext_attr.ml[105,2047+24]..[105,2047+25])
+              signature_item (shortcut_ext_attr.ml[106,2063+2]..[106,2063+29])
+                Psig_modtype "S" (shortcut_ext_attr.ml[106,2063+24]..[106,2063+25])
                   attribute "foo"
                     []
-                  module_type (shortcut_ext_attr.ml[105,2047+28]..[105,2047+29])
-                    Pmty_ident "S" (shortcut_ext_attr.ml[105,2047+28]..[105,2047+29])
+                  module_type (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29])
+                    Pmty_ident "S" (shortcut_ext_attr.ml[106,2063+28]..[106,2063+29])
             ]
-          signature_item (shortcut_ext_attr.ml[107,2078+2]..[107,2078+21]) ghost
+          signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[107,2078+2]..[107,2078+21])
+              signature_item (shortcut_ext_attr.ml[108,2094+2]..[108,2094+21])
                 Psig_include
-                module_type (shortcut_ext_attr.ml[107,2078+20]..[107,2078+21])
-                  Pmty_ident "M" (shortcut_ext_attr.ml[107,2078+20]..[107,2078+21])
+                module_type (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21])
+                  Pmty_ident "M" (shortcut_ext_attr.ml[108,2094+20]..[108,2094+21])
                   attribute "foo"
                     []
             ]
-          signature_item (shortcut_ext_attr.ml[108,2100+2]..[108,2100+18]) ghost
+          signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[108,2100+2]..[108,2100+18])
-                Psig_open Fresh "M" (shortcut_ext_attr.ml[108,2100+17]..[108,2100+18])
+              signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18])
+                Psig_open Fresh "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18])
                   attribute "foo"
                     []
             ]
-          signature_item (shortcut_ext_attr.ml[110,2120+2]..[110,2120+23]) ghost
+          signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[110,2120+2]..[110,2120+23])
+              signature_item (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23])
                 Psig_class
                 [
-                  class_description (shortcut_ext_attr.ml[110,2120+2]..[110,2120+23])
+                  class_description (shortcut_ext_attr.ml[111,2136+2]..[111,2136+23])
                     attribute "foo"
                       []
                     pci_virt = Concrete
                     pci_params =
                       []
-                    pci_name = "x" (shortcut_ext_attr.ml[110,2120+18]..[110,2120+19])
+                    pci_name = "x" (shortcut_ext_attr.ml[111,2136+18]..[111,2136+19])
                     pci_expr =
-                      class_type (shortcut_ext_attr.ml[110,2120+22]..[110,2120+23])
-                        Pcty_constr "t" (shortcut_ext_attr.ml[110,2120+22]..[110,2120+23])
+                      class_type (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23])
+                        Pcty_constr "t" (shortcut_ext_attr.ml[111,2136+22]..[111,2136+23])
                         []
                 ]
             ]
-          signature_item (shortcut_ext_attr.ml[111,2144+2]..[111,2144+28]) ghost
+          signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28]) ghost
             Psig_extension "foo"
             [
-              signature_item (shortcut_ext_attr.ml[111,2144+2]..[111,2144+28])
+              signature_item (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28])
                 Psig_class_type
                 [
-                  class_type_declaration (shortcut_ext_attr.ml[111,2144+2]..[111,2144+28])
+                  class_type_declaration (shortcut_ext_attr.ml[112,2160+2]..[112,2160+28])
                     attribute "foo"
                       []
                     pci_virt = Concrete
                     pci_params =
                       []
-                    pci_name = "x" (shortcut_ext_attr.ml[111,2144+23]..[111,2144+24])
+                    pci_name = "x" (shortcut_ext_attr.ml[112,2160+23]..[112,2160+24])
                     pci_expr =
-                      class_type (shortcut_ext_attr.ml[111,2144+27]..[111,2144+28])
-                        Pcty_constr "x" (shortcut_ext_attr.ml[111,2144+27]..[111,2144+28])
+                      class_type (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28])
+                        Pcty_constr "x" (shortcut_ext_attr.ml[112,2160+27]..[112,2160+28])
                         []
                 ]
             ]
@@ -959,4 +975,4 @@
 ]
 
 File "shortcut_ext_attr.ml", line 4, characters 6-9:
-Uninterpreted extension 'foo'.
+Error: Uninterpreted extension 'foo'.

diff --git a/testsuite/tests/prim-bswap/bswap.ml b/testsuite/tests/prim-bswap/bswap.ml
index 40ab21ff80ac221238ce7b04520e5d0be6be0f6e..9d757335c9103d8061b971319c4797255853248d 100644 (file)
--- a/testsuite/tests/prim-bswap/bswap.ml
+++ b/testsuite/tests/prim-bswap/bswap.ml
@@ -1,16 +1,3 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*                   Benedikt Meurer, os-cillation GmbH                *)
-(*                                                                     *)
-(*    Copyright 1998 Institut National de Recherche en Informatique    *)
-(*    et en Automatique. Copyright 2013 Benedikt Meurer. All rights    *)
-(*    reserved.  This file is distributed  under the terms of the Q    *)
-(*    Public License version 1.0.                                      *)
-(*                                                                     *)
-(***********************************************************************)
-
 open Printf
 
 external bswap16: int -> int = "%bswap16"

diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml
index ad17edea827252cdbadeed53d54100f482cc1840..1a169e18e525b1dfcfdccc1b00ab7d01b3e6571b 100644 (file)
--- a/testsuite/tests/prim-revapply/apply.ml
+++ b/testsuite/tests/prim-revapply/apply.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                   Fabrice Le Fessant, INRIA Saclay                     *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
 
 let f x = x + x

diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml
index c80550049b79350587fdd7e1ed1576a26ab29b06..f8b0dc2e957b891041291c31cd81b8e199efa110 100644 (file)
--- a/testsuite/tests/prim-revapply/revapply.ml
+++ b/testsuite/tests/prim-revapply/revapply.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                   Fabrice Le Fessant, INRIA Saclay                     *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
 
 let f x = x + x

diff --git a/testsuite/tests/regression/pr3612/pr3612.ml b/testsuite/tests/regression/pr3612/pr3612.ml
index 6ae495f86a813795729e76d2a7ffcfb27b8db142..70f4274078f9d3537ba00c15726f0005f3e8f67b 100644 (file)
--- a/testsuite/tests/regression/pr3612/pr3612.ml
+++ b/testsuite/tests/regression/pr3612/pr3612.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                        Pierre Chambart, OCamlPro                       *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 type t
 
 external test_alloc : unit -> t = "caml_test_pr3612_alloc"

diff --git a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
index 6bde667c8275a3287a5a22b12910948a3dffdc7e..175bc8b743a12a7c0454dcbdd8be436afbe85d8d 100644 (file)
--- a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
+++ b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2011 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let marshal_int f  =
   match [] with
   | _ :: `INT n :: _ -> f n

diff --git a/testsuite/tests/regression/pr5233/pr5233.ml b/testsuite/tests/regression/pr5233/pr5233.ml
index 15d3dd9e24849da88adf2e3e667312c3963521b7..b7fddd7f8bf592646e829d1770055804f6a048b6 100644 (file)
--- a/testsuite/tests/regression/pr5233/pr5233.ml
+++ b/testsuite/tests/regression/pr5233/pr5233.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open Printf;;
 
 (* PR#5233: Create a dangling pointer and use it to access random parts

diff --git a/testsuite/tests/regression/pr5757/pr5757.ml b/testsuite/tests/regression/pr5757/pr5757.ml
index ddc4b693588c725d350304b995dc6c6fff394c81..4bd8d85f7e5de84ca19122c2ca08648d201ec417 100644 (file)
--- a/testsuite/tests/regression/pr5757/pr5757.ml
+++ b/testsuite/tests/regression/pr5757/pr5757.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2012 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 Random.init 3;;
 for i = 0 to 100_000 do
   ignore (Bytes.create (Random.int 1_000_000))

diff --git a/testsuite/tests/regression/pr6024/pr6024.ml b/testsuite/tests/regression/pr6024/pr6024.ml
index 0134f3bd0ce72039f8ecba9aae074541bee8a189..7798a5ff09cf39a8026b3ef3e75f9a1493205a55 100644 (file)
--- a/testsuite/tests/regression/pr6024/pr6024.ml
+++ b/testsuite/tests/regression/pr6024/pr6024.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2013 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 Format.printf "@[%@-@@-@]@.";;

diff --git a/testsuite/tests/regression/pr7042/pr7042.ml b/testsuite/tests/regression/pr7042/pr7042.ml
index eeb7ea918a648ba528edc25e709d5c2c772c69e4..3fa80abe959112d96e9c150ebcb5ae1a4b118878 100644 (file)
--- a/testsuite/tests/regression/pr7042/pr7042.ml
+++ b/testsuite/tests/regression/pr7042/pr7042.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*           Xavier Leroy, projet Gallium, INRIA Paris-Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let _ =
   let a = [| 0.0; -. 0.0 |] in
   Printf.printf "%Lx %Lx\n"

diff --git a/testsuite/tests/runtime-errors/stackoverflow.ml b/testsuite/tests/runtime-errors/stackoverflow.ml
index c32fb9a82e4c670e04d4f0fcbeeb9a52d96050af..ab53b8b068eac9122464a165f67a92568bbc2768 100644 (file)
--- a/testsuite/tests/runtime-errors/stackoverflow.ml
+++ b/testsuite/tests/runtime-errors/stackoverflow.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2001 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let rec f x =
   if not (x = 0 || x = 10000 || x = 20000)
   then 1 + f (x + 1)

diff --git a/testsuite/tests/runtime-errors/syserror.ml b/testsuite/tests/runtime-errors/syserror.ml
index 7a318fb79f4d8b8cd67a31b2c70c8b9fc53c2917..46f62eadb0934509b9d6c63e848f37685972ffca 100644 (file)
--- a/testsuite/tests/runtime-errors/syserror.ml
+++ b/testsuite/tests/runtime-errors/syserror.ml
@@ -1,16 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 let channel = open_out "titi:/toto"

diff --git a/testsuite/tests/self-contained-toplevel/Makefile b/testsuite/tests/self-contained-toplevel/Makefile
new file mode 100644 (file)
index 0000000..5126305
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/Makefile
@@ -0,0 +1,34 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                  Jeremie Dimino, Jane Street Europe                    *
+#*                                                                        *
+#*   Copyright 2016 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+LIBRARIES=ocaml
+MODULES=foo cached_cmi
+MAIN_MODULE=main
+COMPFLAGS=-I $(OTOPDIR)/typing -I $(OTOPDIR)/toplevel
+LIBRARIES=../../../compilerlibs/ocamlcommon \
+          ../../../compilerlibs/ocamlbytecomp \
+          ../../../compilerlibs/ocamltoplevel
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+BYTECODE_ONLY=true
+GENERATED_SOURCES+=cached_cmi.ml
+EXEC_ARGS=$(OCFLAGS) -noinit input.ml
+
+cached_cmi.ml: foo.cmi gen_cached_cmi.ml
+       @$(OCAML) ../../../compilerlibs/ocamlcommon.cma -I $(OTOPDIR)/typing \
+                 gen_cached_cmi.ml > $@

diff --git a/testsuite/tests/self-contained-toplevel/foo.ml b/testsuite/tests/self-contained-toplevel/foo.ml
new file mode 100644 (file)
index 0000000..2747ada
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/foo.ml
@@ -0,0 +1 @@
+let value = "Hello, world!"

diff --git a/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml b/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml
new file mode 100644 (file)
index 0000000..176c3b2
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/gen_cached_cmi.ml
@@ -0,0 +1,4 @@
+let () =
+  let cmi = Cmi_format.read_cmi "foo.cmi" in
+  let data = Marshal.to_string cmi [] in
+  Printf.printf "let foo = %S\n" data

diff --git a/testsuite/tests/self-contained-toplevel/input.ml b/testsuite/tests/self-contained-toplevel/input.ml
new file mode 100644 (file)
index 0000000..4607237
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/input.ml
@@ -0,0 +1 @@
+print_endline Foo.value;;

diff --git a/testsuite/tests/self-contained-toplevel/main.ml b/testsuite/tests/self-contained-toplevel/main.ml
new file mode 100644 (file)
index 0000000..606c4df
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/main.ml
@@ -0,0 +1,13 @@
+let () =
+  (* Make sure it's no longer available on disk *)
+  if Sys.file_exists "foo.cmi" then Sys.remove "foo.cmi";
+  let old_loader = !Env.Persistent_signature.load in
+  Env.Persistent_signature.load := (fun ~unit_name ->
+    match unit_name with
+    | "Foo" ->
+      Some { Env.Persistent_signature.
+             filename = Sys.executable_name
+           ; cmi      = Marshal.from_string Cached_cmi.foo 0
+           }
+    | _ -> old_loader unit_name);
+  Topmain.main ()

diff --git a/testsuite/tests/self-contained-toplevel/main.reference b/testsuite/tests/self-contained-toplevel/main.reference
new file mode 100644 (file)
index 0000000..af5626b
--- /dev/null
+++ b/testsuite/tests/self-contained-toplevel/main.reference
@@ -0,0 +1 @@
+Hello, world!

diff --git a/testsuite/tests/tool-lexyacc/gram_aux.ml b/testsuite/tests/tool-lexyacc/gram_aux.ml
index be964b04fdfec7f19f3c7808079839593bf683db..019565f8b0e5613ac8bfd199ab3e894b3f6db8ab 100644 (file)
--- a/testsuite/tests/tool-lexyacc/gram_aux.ml
+++ b/testsuite/tests/tool-lexyacc/gram_aux.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Auxiliaries for the parser. *)
 
 open Syntax

diff --git a/testsuite/tests/tool-lexyacc/grammar.mly b/testsuite/tests/tool-lexyacc/grammar.mly
index 26f9ce51fddce18dc8a431ed2ff48dc4a09cdbbb..02a7155e9f8ef4a3096d71c46f98372adb605b46 100644 (file)
--- a/testsuite/tests/tool-lexyacc/grammar.mly
+++ b/testsuite/tests/tool-lexyacc/grammar.mly
@@ -1,18 +1,3 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                OCaml                                   */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 1996 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
 /* The grammar for lexer definitions */
 
 %{

diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml
index 6c15845634dd2a8dd01a7b41c9ca996ac5376ca3..ff34fe01b5174e98ea40906f23de8584d40c2fb7 100644 (file)
--- a/testsuite/tests/tool-lexyacc/lexgen.ml
+++ b/testsuite/tests/tool-lexyacc/lexgen.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Compiling a lexer definition *)
 
 open Syntax

diff --git a/testsuite/tests/tool-lexyacc/main.ml b/testsuite/tests/tool-lexyacc/main.ml
index 89ee9a1adadecc2215fbfba438adf9548dbbaf2f..16b9a3a9323c38eec50d580e4ab8cd148cd3972a 100644 (file)
--- a/testsuite/tests/tool-lexyacc/main.ml
+++ b/testsuite/tests/tool-lexyacc/main.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* The lexer generator. Command-line parsing. *)
 
 open Syntax

diff --git a/testsuite/tests/tool-lexyacc/output.ml b/testsuite/tests/tool-lexyacc/output.ml
index f8bbb16c59eab0d6c3386cb723e25065b5368162..973aa5e4d3cc4a71f1f9487b157ed30c19010534 100644 (file)
--- a/testsuite/tests/tool-lexyacc/output.ml
+++ b/testsuite/tests/tool-lexyacc/output.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Generating a DFA as a set of mutually recursive functions *)
 
 open Syntax
@@ -22,14 +7,14 @@ let oc = ref stdout
 
 (* 1- Generating the actions *)
 
-let copy_buffer = String.create 1024
+let copy_buffer = Bytes.create 1024
 
 let copy_chunk (Location(start,stop)) =
   seek_in !ic start;
   let tocopy = ref(stop - start) in
   while !tocopy > 0 do
     let m =
-      input !ic copy_buffer 0 (min !tocopy (String.length copy_buffer)) in
+      input !ic copy_buffer 0 (min !tocopy (Bytes.length copy_buffer)) in
     output !oc copy_buffer 0 m;
     tocopy := !tocopy - m
   done

diff --git a/testsuite/tests/tool-lexyacc/scan_aux.ml b/testsuite/tests/tool-lexyacc/scan_aux.ml
index 9f378d5260d4bfbc60b6e5ffd02076b2d017d6cb..96362fcecdcdd3670951b0c7aa9d34ebfa56e29a 100644 (file)
--- a/testsuite/tests/tool-lexyacc/scan_aux.ml
+++ b/testsuite/tests/tool-lexyacc/scan_aux.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* Auxiliaries for the lexical analyzer *)
 
 let brace_depth = ref 0
@@ -20,7 +5,7 @@ let comment_depth = ref 0
 
 exception Lexical_error of string
 
-let initial_string_buffer = String.create 256
+let initial_string_buffer = Bytes.create 256
 let string_buff = ref initial_string_buffer
 let string_index = ref 0
 
@@ -31,17 +16,17 @@ let reset_string_buffer () =
 
 let store_string_char c =
   begin
-    if !string_index >= String.length !string_buff then begin
-      let new_buff = String.create (String.length !string_buff * 2) in
-      String.blit new_buff 0 !string_buff 0 (String.length !string_buff);
+    if !string_index >= Bytes.length !string_buff then begin
+      let new_buff = Bytes.create (Bytes.length !string_buff * 2) in
+      Bytes.blit new_buff 0 !string_buff 0 (Bytes.length !string_buff);
       string_buff := new_buff
     end
   end;
-  String.unsafe_set !string_buff !string_index c;
+  Bytes.unsafe_set !string_buff !string_index c;
   incr string_index
 
 let get_stored_string () =
-  let s = String.sub !string_buff 0 !string_index in
+  let s = Bytes.sub_string !string_buff 0 !string_index in
   string_buff := initial_string_buffer;
   s
 

diff --git a/testsuite/tests/tool-lexyacc/scanner.mll b/testsuite/tests/tool-lexyacc/scanner.mll
index 8e07215add60af6d1f0de630acf69ae098b15c7f..f21fd7cd0b6c6bb2cf5bfa0a9ea5bd4a9afd3eee 100644 (file)
--- a/testsuite/tests/tool-lexyacc/scanner.mll
+++ b/testsuite/tests/tool-lexyacc/scanner.mll
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* The lexical analyzer for lexer definitions. *)
 
 {

diff --git a/testsuite/tests/tool-lexyacc/syntax.ml b/testsuite/tests/tool-lexyacc/syntax.ml
index ece0584eec15060e4a1278111a8b0520178885c6..f692e6f62590591c2a209056add2a2bb56bd36cf 100644 (file)
--- a/testsuite/tests/tool-lexyacc/syntax.ml
+++ b/testsuite/tests/tool-lexyacc/syntax.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* The shallow abstract syntax *)
 
 type location =

diff --git a/testsuite/tests/tool-ocaml/t121-setstringchar.ml b/testsuite/tests/tool-ocaml/t121-setstringchar.ml
index 939ed973e329c524ad697b31aca741f985eae677..ea19572ea57a03472a4d734352d0016398913b8f 100644 (file)
--- a/testsuite/tests/tool-ocaml/t121-setstringchar.ml
+++ b/testsuite/tests/tool-ocaml/t121-setstringchar.ml
@@ -1,7 +1,7 @@
 open Lib;;
-let x = "foo" in
+let x = Bytes.of_string "foo" in
 x.[2] <- 'x';
-if x.[2] <> 'x' then raise Not_found
+if Bytes.get x 2 <> 'x' then raise Not_found
 ;;
 
 (**

diff --git a/testsuite/tests/tool-ocaml/t240-c_call4.ml b/testsuite/tests/tool-ocaml/t240-c_call4.ml
index 7b66ab145712140278155a08c639ba6f4ab878ea..8297eb14bfb6e0d97bbddf91bff0002ef6ed10fb 100644 (file)
--- a/testsuite/tests/tool-ocaml/t240-c_call4.ml
+++ b/testsuite/tests/tool-ocaml/t240-c_call4.ml
@@ -1,7 +1,7 @@
 open Lib;;
-let s = "abcdefgh" in
-String.unsafe_fill s 0 6 'x';
-if s.[5] <> 'x' then raise Not_found
+let s = Bytes.of_string "abcdefgh" in
+Bytes.unsafe_fill s 0 6 'x';
+if Bytes.get s 5 <> 'x' then raise Not_found
 ;;
 
 (**

diff --git a/testsuite/tests/tool-ocaml/t240-c_call5.ml b/testsuite/tests/tool-ocaml/t240-c_call5.ml
index 4c6c92d1fd5c964164b1c26f93063411d38cdfa6..535bb377b1a53eb78e4ee3dd85f8376727ff2212 100644 (file)
--- a/testsuite/tests/tool-ocaml/t240-c_call5.ml
+++ b/testsuite/tests/tool-ocaml/t240-c_call5.ml
@@ -1,7 +1,7 @@
 open Lib;;
-let s = "abcdefgh" in
-String.unsafe_blit s 3 s 0 3;
-if s.[0] <> 'd' then raise Not_found
+let s = Bytes.of_string "abcdefgh" in
+Bytes.unsafe_blit s 3 s 0 3;
+if Bytes.get s 0 <> 'd' then raise Not_found
 ;;
 
 (**

diff --git a/testsuite/tests/tool-ocamldoc-2/Makefile b/testsuite/tests/tool-ocamldoc-2/Makefile
index 372041d5ea5e145fe1b3bc4a591e9711c84e881c..ff155cf14662d4c5308994c15f3cdecb13a55dec 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/Makefile
+++ b/testsuite/tests/tool-ocamldoc-2/Makefile
@@ -33,10 +33,11 @@ default:
        fi
 
 .PHONY: run
-run: *.mli
-       @for file in *.mli; do \
+run: *.ml *.mli
+       @for file in *.mli *.ml; do \
          printf " ... testing '$$file'"; \
          F="`basename $$file .mli`"; \
+         F="`basename $$F .ml`"; \
          $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -latex $ \
                      -o $$F.result $$file; \
          $(DIFF) $$F.reference $$F.result >/dev/null \

diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml b/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
new file mode 100644 (file)
index 0000000..01c67af
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
@@ -0,0 +1,20 @@
+(** Testing display of extensible variant types.
+
+   @test_types_display
+ *)
+
+type e = ..
+
+module M = struct
+  type e +=
+  | A (** A doc *)
+  | B (** B doc *)
+  | C (** C doc *)
+end
+
+module type MT = sig
+  type e +=
+  | A (** A doc *)
+  | B (** B doc *)
+  | C (** C doc *)
+end

diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference b/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
new file mode 100644 (file)
index 0000000..8596200
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
@@ -0,0 +1,108 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Extensible\_variant}} : Testing display of extensible variant types.}
+\label{Extensible-underscorevariant}\index{Extensible-underscorevariant@\verb`Extensible_variant`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{TYPExtensible-underscorevariant.e}\begin{ocamldoccode}
+type e = ..
+\end{ocamldoccode}
+\index{e@\verb`e`}
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{M}}{\tt{ : }}\end{ocamldoccode}
+\label{Extensible-underscorevariant.M}\index{M@\verb`M`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+type e +=
+\end{ocamldoccode}
+\label{extension:Extensible-underscorevariant.M.A}\begin{ocamldoccode}
+  | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+A doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.M.B}\begin{ocamldoccode}
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+B doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.M.C}\begin{ocamldoccode}
+  | C
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+C doc
+
+
+\end{ocamldoccomment}
+\end{ocamldocsigend}
+
+
+
+
+
+
+\begin{ocamldoccode}
+{\tt{module type }}{\tt{MT}}{\tt{ = }}\end{ocamldoccode}
+\label{Extensible-underscorevariant.MT}\index{MT@\verb`MT`}
+
+\begin{ocamldocsigend}
+
+
+\begin{ocamldoccode}
+type e +=
+\end{ocamldoccode}
+\label{extension:Extensible-underscorevariant.MT.A}\begin{ocamldoccode}
+  | A
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+A doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.MT.B}\begin{ocamldoccode}
+  | B
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+B doc
+
+
+\end{ocamldoccomment}
+\label{extension:Extensible-underscorevariant.MT.C}\begin{ocamldoccode}
+  | C
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+C doc
+
+
+\end{ocamldoccomment}
+\end{ocamldocsigend}
+
+
+
+
+\end{document}
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.mli b/testsuite/tests/tool-ocamldoc-2/inline_records.mli
new file mode 100644 (file)
index 0000000..ee5f14d
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records.mli
@@ -0,0 +1,48 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** A less simple exception *)
+exception Less of int
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)

diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.reference b/testsuite/tests/tool-ocamldoc-2/inline_records.reference
new file mode 100644 (file)
index 0000000..84cfb9a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records.reference
@@ -0,0 +1,292 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Inline\_records}} : This test focuses on the printing of documentation for inline record
+  within the latex generator.}
+\label{Inline-underscorerecords}\index{Inline-underscorerecords@\verb`Inline_records`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+exception Simple
+\end{ocamldoccode}
+\index{Simple@\verb`Simple`}
+\begin{ocamldocdescription}
+A nice exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Less of int
+
+\end{ocamldoccode}
+\index{Less@\verb`Less`}
+\begin{ocamldocdescription}
+A less simple exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.ext}\begin{ocamldoccode}
+type ext = ..
+\end{ocamldoccode}
+\index{ext@\verb`ext`}
+\begin{ocamldocdescription}
+An open sum type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.r}\begin{ocamldoccode}
+type r = 
+{\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for non-inline, {\tt{lbl : int}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More documentation for r, {\tt{more : int list}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{r@\verb`r`}
+\begin{ocamldocdescription}
+A simple record type for reference
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.t}\begin{ocamldoccode}
+type t =
+  | A of {\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor documentation
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+A sum type with one inline record
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.s}\begin{ocamldoccode}
+type s =
+  | B of {\char123}  a_label_for_B : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_label_for_B : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor B documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | C of {\char123}  c_has_label_too : float ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{C}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_than_one : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+$\ldots$ documentations
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor C documentation
+
+
+\end{ocamldoccomment}
+\index{s@\verb`s`}
+\begin{ocamldocdescription}
+A sum type with two inline records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords.any}\begin{ocamldoccode}
+type any =
+  | D : {\char123}  any : {\textquotesingle}a ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+ ->
+any
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor D documentation
+
+
+\end{ocamldoccomment}
+\index{any@\verb`any`}
+\begin{ocamldocdescription}
+A gadt constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Error of {\char123}  name : string ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Error field documentation {\tt{name:string}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\index{Error@\verb`Error`}
+
+
+
+
+\begin{ocamldoccode}
+type ext +=
+\end{ocamldoccode}
+\label{extension:Inline-underscorerecords.E}\begin{ocamldoccode}
+  | E of {\char123}  yet_another_field : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for {\tt{E}} in ext
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor E documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords.F}\begin{ocamldoccode}
+  | F of {\char123}  even_more : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Some field documentations for {\tt{F}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor F documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords.G}\begin{ocamldoccode}
+  | G of {\char123}  last : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+The last and least field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor G documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldocdescription}
+Two new constructors for ext
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml
new file mode 100644 (file)
index 0000000..ee5f14d
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.ml
@@ -0,0 +1,48 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** A less simple exception *)
+exception Less of int
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)

diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
new file mode 100644 (file)
index 0000000..6524f48
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
@@ -0,0 +1,291 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Inline\_records\_bis}} : This test focuses on the printing of documentation for inline record
+  within the latex generator.}
+\label{Inline-underscorerecords-underscorebis}\index{Inline-underscorerecords-underscorebis@\verb`Inline_records_bis`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+exception Simple
+\end{ocamldoccode}
+\index{Simple@\verb`Simple`}
+\begin{ocamldocdescription}
+A nice exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Less of int
+
+\end{ocamldoccode}
+\index{Less@\verb`Less`}
+\begin{ocamldocdescription}
+A less simple exception
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.ext}\begin{ocamldoccode}
+type ext = ..
+\end{ocamldoccode}
+\index{ext@\verb`ext`}
+\begin{ocamldocdescription}
+An open sum type
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.r}\begin{ocamldoccode}
+type r = 
+{\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for non-inline, {\tt{lbl : int}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More documentation for r, {\tt{more : int list}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\index{r@\verb`r`}
+\begin{ocamldocdescription}
+A simple record type for reference
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.t}\begin{ocamldoccode}
+type t =
+  | A of {\char123}  lbl : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{A}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor documentation
+
+
+\end{ocamldoccomment}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+A sum type with one inline record
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.s}\begin{ocamldoccode}
+type s =
+  | B of {\char123}  a_label_for_B : int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_label_for_B : int list ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+More {\tt{B}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor B documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  | C of {\char123}  c_has_label_too : float ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{C}} field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+  more_than_one : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+$\ldots$ documentations
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor C documentation
+
+
+\end{ocamldoccomment}
+\index{s@\verb`s`}
+\begin{ocamldocdescription}
+A sum type with two inline records
+
+
+\end{ocamldocdescription}
+
+
+
+
+\label{TYPInline-underscorerecords-underscorebis.any}\begin{ocamldoccode}
+type any =
+  | D : {\char123}  any : {\textquotesingle}a ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+{\tt{A}} field {\tt{any:{\textquotesingle}a}} for {\tt{D}} in {\tt{any}}.
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+ ->
+any
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor D documentation
+
+
+\end{ocamldoccomment}
+\index{any@\verb`any`}
+\begin{ocamldocdescription}
+A gadt constructor
+
+
+\end{ocamldocdescription}
+
+
+
+
+\begin{ocamldoccode}
+exception Error of {\char123}  name : string ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Error field documentation {\tt{name:string}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\index{Error@\verb`Error`}
+
+
+
+
+\begin{ocamldoccode}
+type ext +=
+\end{ocamldoccode}
+\label{extension:Inline-underscorerecords-underscorebis.E}\begin{ocamldoccode}
+  | E of {\char123}  yet_another_field : unit ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Field documentation for {\tt{E}} in ext
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor E documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords-underscorebis.F}\begin{ocamldoccode}
+  | F of {\char123}  even_more : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Some field documentations for {\tt{F}}
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor F documentation
+
+
+\end{ocamldoccomment}
+\label{extension:Inline-underscorerecords-underscorebis.G}\begin{ocamldoccode}
+  | G of {\char123}  last : int -> int ;
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+The last and least field documentation
+
+
+\end{ocamldoccomment}
+\begin{ocamldoccode}
+{\char125}
+
+\end{ocamldoccode}
+\begin{ocamldoccomment}
+Constructor G documentation
+
+
+\end{ocamldoccomment}
+
+
+
+
+Two new constructors for ext
+
+\end{document}
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.mli b/testsuite/tests/tool-ocamldoc-html/Inline_records.mli
new file mode 100644 (file)
index 0000000..f80cd2b
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Inline_records.mli
@@ -0,0 +1,45 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)

diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.reference b/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
new file mode 100644 (file)
index 0000000..856c902
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
@@ -0,0 +1,289 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Inline_records" rel="Chapter" href="Inline_records.html"><title>Inline_records</title>
+</head>
+<body>
+<div class="navbar">&nbsp;<a class="up" href="index.html" title="Index">Up</a>
+&nbsp;</div>
+<h1>Module <a href="type_Inline_records.html">Inline_records</a></h1>
+
+<pre><span class="keyword">module</span> Inline_records: <code class="code"><span class="keyword">sig</span></code> <a href="Inline_records.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+This test focuses on the printing of documentation for inline record
+  within the latex generator.<br>
+</div>
+<hr width="100%">
+
+<pre><span id="EXCEPTIONSimple"><span class="keyword">exception</span> Simple</span></pre>
+<div class="info ">
+A nice exception<br>
+</div>
+
+<pre><span id="TYPEext"><span class="keyword">type</span> <code class="type"></code>ext</span> = ..</pre>
+<div class="info ">
+An open sum type<br>
+</div>
+
+
+<pre><code><span id="TYPEr"><span class="keyword">type</span> <code class="type"></code>r</span> = {</code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTr.lbl">lbl</span>&nbsp;: <code class="type">int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Field documentation for non-inline, <code class="code">lbl&nbsp;:&nbsp;int</code><br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTr.more">more</span>&nbsp;: <code class="type">int list</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+More documentation for r, <code class="code">more&nbsp;:&nbsp;int&nbsp;list</code><br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+
+<div class="info ">
+A simple record type for reference<br>
+</div>
+
+
+<pre><code><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTt.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.A.lbl">lbl</span>&nbsp;: <code class="type">int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<code class="code"><span class="constructor">A</span></code> field documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.A.more">more</span>&nbsp;: <code class="type">int list</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+More <code class="code"><span class="constructor">A</span></code> field documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Constructor documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+A sum type with one inline record<br>
+</div>
+
+
+<pre><code><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.B.a_label_for_B">a_label_for_B</span>&nbsp;: <code class="type">int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<code class="code"><span class="constructor">B</span></code> field documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.B.more_label_for_B">more_label_for_B</span>&nbsp;: <code class="type">int list</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+More <code class="code"><span class="constructor">B</span></code> field documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Constructor B documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTs.C"><span class="constructor">C</span></span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.C.c_has_label_too">c_has_label_too</span>&nbsp;: <code class="type">float</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<code class="code"><span class="constructor">C</span></code> field documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.C.more_than_one">more_than_one</span>&nbsp;: <code class="type">unit</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+... documentations<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Constructor C documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+A sum type with two inline records<br>
+</div>
+
+
+<pre><code><span id="TYPEany"><span class="keyword">type</span> <code class="type"></code>any</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTany.D"><span class="constructor">D</span></span> <span class="keyword">:</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.D.any">any</span>&nbsp;: <code class="type">'a</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+<code class="code"><span class="constructor">A</span></code> field <code class="code">any:<span class="keywordsign">'</span>a</code> for <code class="code"><span class="constructor">D</span></code> in <code class="code">any</code>.<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+ <span class="keyword">-></span> <code class="type"><a href="Inline_records.html#TYPEany">any</a></code></code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Constructor D documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+A gadt constructor<br>
+</div>
+
+
+<pre><span id="EXCEPTIONError"><span class="keyword">exception</span> Error</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.Error.name">name</span>&nbsp;: <code class="type">string</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Error field documentation <code class="code">name:string</code><br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</pre>
+<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Inline_records.html#TYPEext">ext</a> += </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONE">E</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.E.yet_another_field">yet_another_field</span>&nbsp;: <code class="type">unit</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Field documentation for <code class="code"><span class="constructor">E</span></code> in ext<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Constructor E documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONF">F</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.F.even_more">even_more</span>&nbsp;: <code class="type">int -> int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Some field documentations for <code class="code"><span class="constructor">F</span></code><br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Constructor F documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr>
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONG">G</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTInline_records.G.last">last</span>&nbsp;: <code class="type">int -> int</code>;</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+The last and least field documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+}
+</code></td>
+<td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
+Constructor G documentation<br>
+</div>
+</td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
+</tr></table>
+
+<div class="info ">
+Two new constructors for ext<br>
+</div>
+
+</body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli b/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
new file mode 100644 (file)
index 0000000..764e7f4
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
@@ -0,0 +1,69 @@
+(**
+   This file tests the encoding of linebreak inside OCaml code by the
+   ocamldoc html backend.
+
+   Two slightly different aspects are tested in this very file.
+
+   - First, inside a "pre" tags, blanks character should not be escaped.
+   For instance, the generated html code for this test fragment should not
+   contain any <br> tag:
+   {[
+     let f x =
+       let g x =
+         let h x = x in
+         h x in
+       g x
+   ]}
+   See {{:http://caml.inria.fr/mantis/view.php?id=6341} MPR#6341} for more
+   details or the file Linebreaks.html generated by ocamldoc from this file.
+
+   -Second, outside of a "pre"  tags, blank characters in embedded code
+   should be escaped, in order to make them render in a "pre"-like fashion.
+   A good example should be the files type_{i Modulename}.html generated by
+   ocamldoc that should contains the signature of the module [Modulename] in
+   a "code" tags.
+   For instance with the following type definitions,
+*)
+
+type a = A
+type 'a b = {field:'a}
+type c = C: 'a -> c
+
+type s = ..
+type s += B
+
+val x : a
+
+module S: sig module I:sig end end
+module type s = sig end
+
+class type d = object end
+
+exception E of {inline:int}
+
+
+(** type_Linebreaks.html should contain
+
+{[
+sig
+  type a = A
+  type 'a b = { field : 'a; }
+  type c = C : 'a -> Linebreaks.c
+  type s = ..
+  type s += B
+  val x : Linebreaks.a
+  module S : sig module I : sig  end end
+  module type s = sig  end
+  class type d = object  end
+  exception E of { inline : int; }
+end
+]}
+
+with <br> tags used for linebreaks.
+Another example would be [ let f x =
+x] which is rendered with a <br> linebreak inside Linebreaks.html.
+
+See {{:http://caml.inria.fr/mantis/view.php?id=7272}MPR#7272} for more
+information.
+
+*)

diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference b/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
new file mode 100644 (file)
index 0000000..71a020f
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
@@ -0,0 +1,140 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of class types" rel=Appendix href="index_class_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Index of module types" rel=Appendix href="index_module_types.html">
+<link title="Linebreaks" rel="Chapter" href="Linebreaks.html"><title>Linebreaks</title>
+</head>
+<body>
+<div class="navbar">&nbsp;<a class="up" href="index.html" title="Index">Up</a>
+&nbsp;</div>
+<h1>Module <a href="type_Linebreaks.html">Linebreaks</a></h1>
+
+<pre><span class="keyword">module</span> Linebreaks: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+This file tests the encoding of linebreak inside OCaml code by the
+   ocamldoc html backend.
+<p>
+
+   Two slightly different aspects are tested in this very file.
+<p>
+<ul>
+<li>First, inside a "pre" tags, blanks character should not be escaped.
+   For instance, the generated html code for this test fragment should not
+   contain any &lt;br&gt; tag:
+   <pre class="codepre"><code class="code">     <span class="keyword">let</span> f x =
+       <span class="keyword">let</span> g x =
+         <span class="keyword">let</span> h x = x <span class="keyword">in</span>
+         h x <span class="keyword">in</span>
+       g x
+   </code></pre>
+   See <a href="http://caml.inria.fr/mantis/view.php?id=6341"> MPR#6341</a> for more
+   details or the file Linebreaks.html generated by ocamldoc from this file.</li>
+</ul>
+
+   -Second, outside of a "pre"  tags, blank characters in embedded code
+   should be escaped, in order to make them render in a "pre"-like fashion.
+   A good example should be the files type_<i>Modulename</i>.html generated by
+   ocamldoc that should contains the signature of the module <code class="code"><span class="constructor">Modulename</span></code> in
+   a "code" tags.
+   For instance with the following type definitions,<br>
+</div>
+<hr width="100%">
+
+<pre><code><span id="TYPEa"><span class="keyword">type</span> <code class="type"></code>a</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTa.A"><span class="constructor">A</span></span></code></td>
+
+</tr></table>
+
+
+
+<pre><code><span id="TYPEb"><span class="keyword">type</span> <code class="type">'a</code> b</span> = {</code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTb.field">field</span>&nbsp;: <code class="type">'a</code>;</code></td>
+
+</tr></table>
+}
+
+
+
+<pre><code><span id="TYPEc"><span class="keyword">type</span> <code class="type"></code>c</span> = </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTc.C"><span class="constructor">C</span></span> <span class="keyword">:</span> <code class="type">'a</code> <span class="keyword">-></span> <code class="type"><a href="Linebreaks.html#TYPEc">c</a></code></code></td>
+
+</tr></table>
+
+
+
+<pre><span id="TYPEs"><span class="keyword">type</span> <code class="type"></code>s</span> = ..</pre>
+
+<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Linebreaks.html#TYPEs">s</a> += </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONB">B</span></code></td>
+
+</tr></table>
+
+
+
+<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type"><a href="Linebreaks.html#TYPEa">a</a></code></pre>
+<pre><span class="keyword">module</span> <a href="Linebreaks.S.html">S</a>: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.S.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span class="keyword">module type</span> <a href="Linebreaks.s-c.html">s</a> = <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.s-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="TYPEd"><span class="keyword">class type</span> <a href="Linebreaks.d-c.html">d</a></span> = <code class="code"><span class="keyword">object</span></code> <a href="Linebreaks.d-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="EXCEPTIONE"><span class="keyword">exception</span> E</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code>&nbsp;&nbsp;</code></td>
+<td align="left" valign="top" >
+<code><span id="TYPEELTLinebreaks.E.inline">inline</span>&nbsp;: <code class="type">int</code>;</code></td>
+
+</tr></table>
+}
+</pre>
+<br>
+type_Linebreaks.html should contain
+<p>
+
+<pre class="codepre"><code class="code"><span class="keyword">sig</span>
+  <span class="keyword">type</span> a = <span class="constructor">A</span>
+  <span class="keyword">type</span> <span class="keywordsign">'</span>a b = { field : <span class="keywordsign">'</span>a; }
+  <span class="keyword">type</span> c = <span class="constructor">C</span> : <span class="keywordsign">'</span>a <span class="keywordsign">-&gt;</span> <span class="constructor">Linebreaks</span>.c
+  <span class="keyword">type</span> s = ..
+  <span class="keyword">type</span> s += <span class="constructor">B</span>
+  <span class="keyword">val</span> x : <span class="constructor">Linebreaks</span>.a
+  <span class="keyword">module</span> <span class="constructor">S</span> : <span class="keyword">sig</span> <span class="keyword">module</span> <span class="constructor">I</span> : <span class="keyword">sig</span>  <span class="keyword">end</span> <span class="keyword">end</span>
+  <span class="keyword">module</span> <span class="keyword">type</span> s = <span class="keyword">sig</span>  <span class="keyword">end</span>
+  <span class="keyword">class</span> <span class="keyword">type</span> d = <span class="keyword">object</span>  <span class="keyword">end</span>
+  <span class="keyword">exception</span> <span class="constructor">E</span> <span class="keyword">of</span> { inline : int; }
+<span class="keyword">end</span>
+</code></pre>
+<p>
+
+with &lt;br&gt; tags used for linebreaks.
+Another example would be <code class="code">&nbsp;<span class="keyword">let</span>&nbsp;f&nbsp;x&nbsp;=<br>
+x</code> which is rendered with a &lt;br&gt; linebreak inside Linebreaks.html.
+<p>
+
+See <a href="http://caml.inria.fr/mantis/view.php?id=7272">MPR#7272</a> for more
+information.<br>
+</body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Makefile b/testsuite/tests/tool-ocamldoc-html/Makefile
new file mode 100644 (file)
index 0000000..c9160b4
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Makefile
@@ -0,0 +1,60 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
+       -latextitle "6,subsection*" \
+       -latextitle "7,subsubsection*" \
+       -latex-type-prefix "TYP" \
+       -latex-module-prefix "" \
+       -latex-module-type-prefix "" \
+       -latex-value-prefix ""
+
+.PHONY: default
+default:
+       @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+         echo 'skipped (shared libraries not available)'; \
+       else \
+         $(SET_LD_PATH) $(MAKE) run; \
+       fi
+
+.PHONY: run
+run: *.mli
+       @for file in *.mli; do \
+         printf " ... testing '$$file'"; \
+         F="`basename $$file .mli`"; \
+         $(OCAMLDOC) $(DOCFLAGS) -colorize-code -hide-warnings -html $ \
+                     -o index $$file; \
+         cp $$F.html $$F.result; \
+         $(DIFF) $$F.reference $$F.result >/dev/null \
+         && echo " => passed" || echo " => failed"; \
+       done;\
+# For linebreaks.mli, we also compare type_Linebreaks.html and not only
+# themain html file
+       @cp type_Linebreaks.html type_Linebreaks.result;\
+       printf " ... testing 'type_Linebreak.html'";\
+       $(DIFF) type_Linebreaks.reference type_Linebreaks.result\
+       && echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+       @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
+
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference b/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference
new file mode 100644 (file)
index 0000000..ad097f1
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/type_Linebreaks.reference
@@ -0,0 +1,27 @@
+<html><head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of class types" rel=Appendix href="index_class_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Index of module types" rel=Appendix href="index_module_types.html">
+<link title="Linebreaks" rel="Chapter" href="Linebreaks.html"><title>Linebreaks</title>
+</head>
+<body>
+<code class="code"><span class="keyword">sig</span><br>
+&nbsp;&nbsp;<span class="keyword">type</span>&nbsp;a&nbsp;=&nbsp;<span class="constructor">A</span><br>
+&nbsp;&nbsp;<span class="keyword">type</span>&nbsp;<span class="keywordsign">'</span>a&nbsp;b&nbsp;=&nbsp;{&nbsp;field&nbsp;:&nbsp;<span class="keywordsign">'</span>a;&nbsp;}<br>
+&nbsp;&nbsp;<span class="keyword">type</span>&nbsp;c&nbsp;=&nbsp;<span class="constructor">C</span>&nbsp;:&nbsp;<span class="keywordsign">'</span>a&nbsp;<span class="keywordsign">-&gt;</span>&nbsp;<span class="constructor">Linebreaks</span>.c<br>
+&nbsp;&nbsp;<span class="keyword">type</span>&nbsp;s&nbsp;=&nbsp;..<br>
+&nbsp;&nbsp;<span class="keyword">type</span>&nbsp;s&nbsp;+=&nbsp;<span class="constructor">B</span><br>
+&nbsp;&nbsp;<span class="keyword">val</span>&nbsp;x&nbsp;:&nbsp;<span class="constructor">Linebreaks</span>.a<br>
+&nbsp;&nbsp;<span class="keyword">module</span>&nbsp;<span class="constructor">S</span>&nbsp;:&nbsp;<span class="keyword">sig</span>&nbsp;<span class="keyword">module</span>&nbsp;<span class="constructor">I</span>&nbsp;:&nbsp;<span class="keyword">sig</span>&nbsp;&nbsp;<span class="keyword">end</span>&nbsp;<span class="keyword">end</span><br>
+&nbsp;&nbsp;<span class="keyword">module</span>&nbsp;<span class="keyword">type</span>&nbsp;s&nbsp;=&nbsp;<span class="keyword">sig</span>&nbsp;&nbsp;<span class="keyword">end</span><br>
+&nbsp;&nbsp;<span class="keyword">class</span>&nbsp;<span class="keyword">type</span>&nbsp;d&nbsp;=&nbsp;<span class="keyword">object</span>&nbsp;&nbsp;<span class="keyword">end</span><br>
+&nbsp;&nbsp;<span class="keyword">exception</span>&nbsp;<span class="constructor">E</span>&nbsp;<span class="keyword">of</span>&nbsp;{&nbsp;inline&nbsp;:&nbsp;int;&nbsp;}<br>
+<span class="keyword">end</span></code></body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-man/Inline_records.mli b/testsuite/tests/tool-ocamldoc-man/Inline_records.mli
new file mode 100644 (file)
index 0000000..f80cd2b
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Inline_records.mli
@@ -0,0 +1,45 @@
+(**
+  This test focuses on the printing of documentation for inline record
+  within the latex generator.
+*)
+
+
+(** A nice exception *)
+exception Simple
+
+(** An open sum type *)
+type ext = ..
+
+(** A simple record type for reference *)
+type r = { lbl: int (** Field documentation for non-inline, [lbl : int] *);
+          more:int list (** More documentation for r, [more : int list] *) }
+
+
+(** A sum type with one inline record *)
+type t = A of {lbl: int (** [A] field documentation *)
+              ; more:int list (** More [A] field documentation *) }
+(** Constructor documentation *)
+
+(** A sum type with two inline records *)
+type s =
+  | B of { a_label_for_B : int (** [B] field documentation *);
+               more_label_for_B:int list (** More [B] field documentation *) }
+  (** Constructor B documentation *)
+  | C of { c_has_label_too: float (** [C] field documentation*);
+           more_than_one: unit (** ... documentations *)  }
+  (** Constructor C documentation *)
+
+(** A gadt constructor *)
+type any = D: { any:'a (** [A] field [any:'a] for [D] in [any]. *) } -> any
+(** Constructor D documentation *)
+
+exception Error of {name:string (** Error field documentation [name:string] *) }
+
+type ext +=
+  | E of { yet_another_field: unit (** Field documentation for [E] in ext *) }
+  (** Constructor E documentation *)
+  | F of { even_more: int -> int (** Some field documentations for [F] *) }
+  (** Constructor F documentation *)
+  | G of { last: int -> int (** The last and least field documentation *) }
+  (** Constructor G documentation *)
+(** Two new constructors for ext *)

diff --git a/testsuite/tests/tool-ocamldoc-man/Inline_records.reference b/testsuite/tests/tool-ocamldoc-man/Inline_records.reference
new file mode 100644 (file)
index 0000000..7184b97
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Inline_records.reference
@@ -0,0 +1,201 @@
+.SH NAME
+Inline_records \- This test focuses on the printing of documentation for inline record within the latex generator.
+.SH Module
+Module   Inline_records
+.SH Documentation
+.sp
+Module
+.BI "Inline_records"
+ : 
+.B sig  end
+
+.sp
+This test focuses on the printing of documentation for inline record
+within the latex generator\&.
+
+.sp
+
+.sp
+.sp
+
+.I exception Simple 
+
+.sp
+A nice exception
+
+.sp
+.I type ext 
+= ..
+
+.sp
+An open sum type
+
+.sp
+.I type r 
+= {
+ lbl : 
+.B int
+;  (* Field documentation for non\-inline, 
+.B lbl : int
+
+ *) 
+ more : 
+.B int list
+;  (* More documentation for r, 
+.B more : int list
+
+ *) 
+ }
+
+.sp
+A simple record type for reference
+
+.sp
+.I type t 
+=
+ | A
+.B of {
+ lbl : 
+.B int
+;  (* 
+.B A
+field documentation
+ *) 
+ more : 
+.B int list
+;  (* More 
+.B A
+field documentation
+ *) 
+ }
+.I "  "
+  (* Constructor documentation
+ *)
+ 
+.sp
+A sum type with one inline record
+
+.sp
+.I type s 
+=
+ | B
+.B of {
+ a_label_for_B : 
+.B int
+;  (* 
+.B B
+field documentation
+ *) 
+ more_label_for_B : 
+.B int list
+;  (* More 
+.B B
+field documentation
+ *) 
+ }
+.I "  "
+  (* Constructor B documentation
+ *)
+ | C
+.B of {
+ c_has_label_too : 
+.B float
+;  (* 
+.B C
+field documentation
+ *) 
+ more_than_one : 
+.B unit
+;  (* \&.\&.\&. documentations
+ *) 
+ }
+.I "  "
+  (* Constructor C documentation
+ *)
+ 
+.sp
+A sum type with two inline records
+
+.sp
+.I type any 
+=
+ | D
+.B of {
+ any : 
+.B 'a
+;  (* 
+.B A
+field 
+.B any:\&'a
+for 
+.B D
+in 
+.B any
+\&.
+ *) 
+ }
+.B -> 
+.B any
+.I "  "
+  (* Constructor D documentation
+ *)
+ 
+.sp
+A gadt constructor
+
+.sp
+
+.I exception Error 
+.B of {
+ name : 
+.B string
+;  (* Error field documentation 
+.B name:string
+
+ *) 
+ }
+
+.sp
+
+.sp
+.I type ext 
++=
+ | E
+.B of {
+ yet_another_field : 
+.B unit
+;  (* Field documentation for 
+.B E
+in ext
+ *) 
+ }
+.I "  "
+(* Constructor E documentation
+ *)
+ | F
+.B of {
+ even_more : 
+.B int -> int
+;  (* Some field documentations for 
+.B F
+
+ *) 
+ }
+.I "  "
+(* Constructor F documentation
+ *)
+ | G
+.B of {
+ last : 
+.B int -> int
+;  (* The last and least field documentation
+ *) 
+ }
+.I "  "
+(* Constructor G documentation
+ *)
+ 
+.sp
+Two new constructors for ext
+
+.sp

diff --git a/testsuite/tests/tool-ocamldoc-man/Makefile b/testsuite/tests/tool-ocamldoc-man/Makefile
new file mode 100644 (file)
index 0000000..a3c272a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-man/Makefile
@@ -0,0 +1,54 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
+       -latextitle "6,subsection*" \
+       -latextitle "7,subsubsection*" \
+       -latex-type-prefix "TYP" \
+       -latex-module-prefix "" \
+       -latex-module-type-prefix "" \
+       -latex-value-prefix ""
+
+.PHONY: default
+default:
+       @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+         echo 'skipped (shared libraries not available)'; \
+       else \
+         $(SET_LD_PATH) $(MAKE) run; \
+       fi
+
+.PHONY: run
+run: *.mli
+       @for file in *.mli; do \
+         printf " ... testing '$$file'"; \
+         F="`basename $$file .mli`"; \
+         $(OCAMLDOC) $(DOCFLAGS) -hide-warnings -man $ \
+                     -o index $$file; \
+         tail -n +2 $$F.3o > $$F.result; \
+         $(DIFF) $$F.reference $$F.result >/dev/null \
+         && echo " => passed" || echo " => failed"; \
+       done
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+       @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux *.3o
+
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/tool-ocamldoc-open/Makefile b/testsuite/tests/tool-ocamldoc-open/Makefile
new file mode 100644 (file)
index 0000000..f54566a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/Makefile
@@ -0,0 +1,47 @@
+BASEDIR=../..
+COMPFLAGS=-I $(OTOPDIR)/ocamldoc
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
+DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)
+
+SRC= main.ml alias.ml inner.ml
+ODOCS=$(SRC:%.ml=%.odoc)
+
+.PHONY: default
+default:
+       @if ! $(SUPPORTS_SHARED_LIBRARIES); then \
+         echo 'skipped (shared libraries not available)'; \
+       else \
+         $(SET_LD_PATH) $(MAKE) doc; \
+       fi
+
+.PHONY: doc
+doc: $(ODOCS)
+       @printf " ... testing ocamldoc '-open' option";\
+       $(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+         -load alias.odoc -load inner.odoc \
+         -load main.odoc -latex -o doc.result ;\
+       $(DIFF) doc.result doc.reference > /dev/null \
+       && echo " => passed" || echo " => failed";
+
+inner.odoc: inner.ml
+       @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -dump inner.odoc inner.ml
+
+alias.odoc: inner.cmi alias.ml
+       @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -dump alias.odoc alias.ml
+
+main.odoc: alias.cmi main.ml
+       @$(OCAMLDOC) $(DOCFLAGS) -hide-warnings \
+        -open Alias -open Aliased_inner -dump main.odoc main.ml
+
+alias.cmi:inner.cmi
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+       @rm -f *.odoc *.toc *.sty *.aux *.log *.result
+
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/tool-ocamldoc-open/Readme b/testsuite/tests/tool-ocamldoc-open/Readme
new file mode 100644 (file)
index 0000000..e140d57
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/Readme
@@ -0,0 +1,12 @@
+This test focuses on ocamldoc "-open" command line option.
+It ensures that the modules passed as argument to this "-open" option
+are opened in the initial environment of ocamldoc.
+
+More precisely, it checks that
+
+* both cmi files and inner modules can be opened
+* modules are opened in the left-to-right order
+
+The test builds a latex documentation file for the three modules
+"Main", "Alias" and "Inner". Changes to ocamldoc latex output might
+trigger spurious errors in this test.

diff --git a/testsuite/tests/tool-ocamldoc-open/alias.ml b/testsuite/tests/tool-ocamldoc-open/alias.ml
new file mode 100644 (file)
index 0000000..50a8f4f
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/alias.ml
@@ -0,0 +1 @@
+module Aliased_inner = Inner

diff --git a/testsuite/tests/tool-ocamldoc-open/doc.reference b/testsuite/tests/tool-ocamldoc-open/doc.reference
new file mode 100644 (file)
index 0000000..c372d15
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/doc.reference
@@ -0,0 +1,61 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Alias}}}
+\label{module:Alias}\index{Alias@\verb`Alias`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\begin{ocamldoccode}
+{\tt{module }}{\tt{Aliased\_inner}}{\tt{ : }}\end{ocamldoccode}
+\label{module:Alias.Aliased-underscoreinner}\index{Aliased-underscoreinner@\verb`Aliased_inner`}
+
+{\tt{Inner}}
+
+
+
+\section{Module {\tt{Inner}}}
+\label{module:Inner}\index{Inner@\verb`Inner`}
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{type:Inner.a}\begin{ocamldoccode}
+type a = int 
+\end{ocamldoccode}
+\index{a@\verb`a`}
+
+
+\section{Module {\tt{Main}} : Documentation test}
+\label{module:Main}\index{Main@\verb`Main`}
+
+
+
+
+\ocamldocvspace{0.5cm}
+
+
+
+\label{type:Main.t}\begin{ocamldoccode}
+type t = Alias.Aliased_inner.a 
+\end{ocamldoccode}
+\index{t@\verb`t`}
+\begin{ocamldocdescription}
+Alias to type Inner.a
+
+
+\end{ocamldocdescription}
+
+
+\end{document}
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-open/inner.ml b/testsuite/tests/tool-ocamldoc-open/inner.ml
new file mode 100644 (file)
index 0000000..8777863
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/inner.ml
@@ -0,0 +1,2 @@
+
+type a = int

diff --git a/testsuite/tests/tool-ocamldoc-open/main.ml b/testsuite/tests/tool-ocamldoc-open/main.ml
new file mode 100644 (file)
index 0000000..abc1f81
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-open/main.ml
@@ -0,0 +1,5 @@
+
+(** Documentation test *)
+
+type t = a
+(** Alias to type Inner.a *)

diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml
index 9e34bb2a1c1a53b032435e76ebf65d9c31627ddb..068f1e09559572cea7e561ea01312b2e4be18e9c 100644 (file)
--- a/testsuite/tests/tool-ocamldoc/odoc_test.ml
+++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml
@@ -1,15 +1,3 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                             OCamldoc                                *)
-(*                                                                     *)
-(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
-(*                                                                     *)
-(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
 (** Custom generator to perform test on ocamldoc. *)
 
 open Odoc_info

diff --git a/testsuite/tests/tool-ocamldoc/t04.ml b/testsuite/tests/tool-ocamldoc/t04.ml
new file mode 100644 (file)
index 0000000..97782ae
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t04.ml
@@ -0,0 +1,20 @@
+(** Testing display of inline record.
+
+   @test_types_display
+ *)
+
+
+module A = struct
+  type a = A of {lbl:int}
+
+end
+
+module type E = sig
+  exception E of {lbl:int}
+
+end
+
+
+module E_bis= struct
+  exception E of {lbl:int}
+end

diff --git a/testsuite/tests/tool-ocamldoc/t04.reference b/testsuite/tests/tool-ocamldoc/t04.reference
new file mode 100644 (file)
index 0000000..924503e
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/t04.reference
@@ -0,0 +1,27 @@
+#
+# module T04:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig  end]>
+#
+# module T04.A:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig type a = A of { lbl : int; } end]>
+# type T04.A.a:
+# manifest (Odoc_info.string_of_type_expr):
+<[None]>
+#
+# module type T04.E:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig exception E of { lbl : int; } end]>
+#
+# module T04.E_bis:
+# Odoc_info.string_of_module_type:
+<[sig  end]>
+# Odoc_info.string_of_module_type ~complete: true :
+<[sig exception E of { lbl : int; } end]>

diff --git a/testsuite/tests/translprim/comparison_table.ml.reference b/testsuite/tests/translprim/comparison_table.ml.reference
index 22d533ecdd6c7a926dd1a334ef2f5d19ffc7d827..525ff898cf8df9a2efcce28440f0c6c9b5eb7213 100644 (file)
--- a/testsuite/tests/translprim/comparison_table.ml.reference
+++ b/testsuite/tests/translprim/comparison_table.ml.reference
@@ -1,381 +1,364 @@
 (setglobal Comparison_table!
-  (seq (opaque (global List!))
-    (let
-      (gen_cmp = (function x y (caml_compare x y))
-       int_cmp =
-         (function x y (caml_int_compare x y))
-       bool_cmp =
-         (function x y (caml_int_compare x y))
-       intlike_cmp =
-         (function x y (caml_int_compare x y))
-       float_cmp =
-         (function x y (caml_float_compare x y))
-       string_cmp =
-         (function x y (caml_string_compare x y))
-       int32_cmp =
-         (function x y (caml_int32_compare x y))
-       int64_cmp =
-         (function x y (caml_int64_compare x y))
-       nativeint_cmp =
-         (function x y (caml_nativeint_compare x y))
-       gen_eq = (function x y (caml_equal x y))
-       int_eq = (function x y (== x y))
-       bool_eq = (function x y (== x y))
-       intlike_eq = (function x y (== x y))
-       float_eq = (function x y (==. x y))
-       string_eq =
-         (function x y (caml_string_equal x y))
-       int32_eq = (function x y (Int32.== x y))
-       int64_eq = (function x y (Int64.== x y))
-       nativeint_eq =
-         (function x y (Nativeint.== x y))
-       gen_ne = (function x y (caml_notequal x y))
-       int_ne = (function x y (!= x y))
-       bool_ne = (function x y (!= x y))
-       intlike_ne = (function x y (!= x y))
-       float_ne = (function x y (!=. x y))
-       string_ne =
-         (function x y (caml_string_notequal x y))
-       int32_ne = (function x y (Int32.!= x y))
-       int64_ne = (function x y (Int64.!= x y))
-       nativeint_ne =
-         (function x y (Nativeint.!= x y))
-       gen_lt = (function x y (caml_lessthan x y))
-       int_lt = (function x y (< x y))
-       bool_lt = (function x y (< x y))
-       intlike_lt = (function x y (< x y))
-       float_lt = (function x y (<. x y))
-       string_lt =
-         (function x y (caml_string_lessthan x y))
-       int32_lt = (function x y (Int32.< x y))
-       int64_lt = (function x y (Int64.< x y))
-       nativeint_lt =
-         (function x y (Nativeint.< x y))
-       gen_gt =
-         (function x y (caml_greaterthan x y))
-       int_gt = (function x y (> x y))
-       bool_gt = (function x y (> x y))
-       intlike_gt = (function x y (> x y))
-       float_gt = (function x y (>. x y))
-       string_gt =
-         (function x y (caml_string_greaterthan x y))
-       int32_gt = (function x y (Int32.> x y))
-       int64_gt = (function x y (Int64.> x y))
-       nativeint_gt =
-         (function x y (Nativeint.> x y))
-       gen_le = (function x y (caml_lessequal x y))
-       int_le = (function x y (<= x y))
-       bool_le = (function x y (<= x y))
-       intlike_le = (function x y (<= x y))
-       float_le = (function x y (<=. x y))
-       string_le =
-         (function x y (caml_string_lessequal x y))
-       int32_le = (function x y (Int32.<= x y))
-       int64_le = (function x y (Int64.<= x y))
-       nativeint_le =
-         (function x y (Nativeint.<= x y))
-       gen_ge =
-         (function x y (caml_greaterequal x y))
-       int_ge = (function x y (>= x y))
-       bool_ge = (function x y (>= x y))
-       intlike_ge = (function x y (>= x y))
-       float_ge = (function x y (>=. x y))
-       string_ge =
-         (function x y (caml_string_greaterequal x y))
-       int32_ge = (function x y (Int32.>= x y))
-       int64_ge = (function x y (Int64.>= x y))
-       nativeint_ge =
-         (function x y (Nativeint.>= x y))
-       eta_gen_cmp =
-         (function prim prim (caml_compare prim prim))
-       eta_int_cmp =
-         (function prim prim
-           (caml_int_compare prim prim))
-       eta_bool_cmp =
-         (function prim prim
-           (caml_int_compare prim prim))
-       eta_intlike_cmp =
-         (function prim prim
-           (caml_int_compare prim prim))
-       eta_float_cmp =
-         (function prim prim
-           (caml_float_compare prim prim))
-       eta_string_cmp =
-         (function prim prim
-           (caml_string_compare prim prim))
-       eta_int32_cmp =
-         (function prim prim
-           (caml_int32_compare prim prim))
-       eta_int64_cmp =
-         (function prim prim
-           (caml_int64_compare prim prim))
-       eta_nativeint_cmp =
-         (function prim prim
-           (caml_nativeint_compare prim prim))
-       eta_gen_eq =
-         (function prim prim (caml_equal prim prim))
-       eta_int_eq =
-         (function prim prim (== prim prim))
-       eta_bool_eq =
-         (function prim prim (== prim prim))
-       eta_intlike_eq =
-         (function prim prim (== prim prim))
-       eta_float_eq =
-         (function prim prim (==. prim prim))
-       eta_string_eq =
-         (function prim prim
-           (caml_string_equal prim prim))
-       eta_int32_eq =
-         (function prim prim (Int32.== prim prim))
-       eta_int64_eq =
-         (function prim prim (Int64.== prim prim))
-       eta_nativeint_eq =
-         (function prim prim (Nativeint.== prim prim))
-       eta_gen_ne =
-         (function prim prim (caml_notequal prim prim))
-       eta_int_ne =
-         (function prim prim (!= prim prim))
-       eta_bool_ne =
-         (function prim prim (!= prim prim))
-       eta_intlike_ne =
-         (function prim prim (!= prim prim))
-       eta_float_ne =
-         (function prim prim (!=. prim prim))
-       eta_string_ne =
-         (function prim prim
-           (caml_string_notequal prim prim))
-       eta_int32_ne =
-         (function prim prim (Int32.!= prim prim))
-       eta_int64_ne =
-         (function prim prim (Int64.!= prim prim))
-       eta_nativeint_ne =
-         (function prim prim (Nativeint.!= prim prim))
-       eta_gen_lt =
-         (function prim prim (caml_lessthan prim prim))
-       eta_int_lt =
-         (function prim prim (< prim prim))
-       eta_bool_lt =
-         (function prim prim (< prim prim))
-       eta_intlike_lt =
-         (function prim prim (< prim prim))
-       eta_float_lt =
-         (function prim prim (<. prim prim))
-       eta_string_lt =
-         (function prim prim
-           (caml_string_lessthan prim prim))
-       eta_int32_lt =
-         (function prim prim (Int32.< prim prim))
-       eta_int64_lt =
-         (function prim prim (Int64.< prim prim))
-       eta_nativeint_lt =
-         (function prim prim (Nativeint.< prim prim))
-       eta_gen_gt =
-         (function prim prim
-           (caml_greaterthan prim prim))
-       eta_int_gt =
-         (function prim prim (> prim prim))
-       eta_bool_gt =
-         (function prim prim (> prim prim))
-       eta_intlike_gt =
-         (function prim prim (> prim prim))
-       eta_float_gt =
-         (function prim prim (>. prim prim))
-       eta_string_gt =
-         (function prim prim
-           (caml_string_greaterthan prim prim))
-       eta_int32_gt =
-         (function prim prim (Int32.> prim prim))
-       eta_int64_gt =
-         (function prim prim (Int64.> prim prim))
-       eta_nativeint_gt =
-         (function prim prim (Nativeint.> prim prim))
-       eta_gen_le =
-         (function prim prim (caml_lessequal prim prim))
-       eta_int_le =
-         (function prim prim (<= prim prim))
-       eta_bool_le =
-         (function prim prim (<= prim prim))
-       eta_intlike_le =
-         (function prim prim (<= prim prim))
-       eta_float_le =
-         (function prim prim (<=. prim prim))
-       eta_string_le =
-         (function prim prim
-           (caml_string_lessequal prim prim))
-       eta_int32_le =
-         (function prim prim (Int32.<= prim prim))
-       eta_int64_le =
-         (function prim prim (Int64.<= prim prim))
-       eta_nativeint_le =
-         (function prim prim (Nativeint.<= prim prim))
-       eta_gen_ge =
-         (function prim prim
-           (caml_greaterequal prim prim))
-       eta_int_ge =
-         (function prim prim (>= prim prim))
-       eta_bool_ge =
-         (function prim prim (>= prim prim))
-       eta_intlike_ge =
-         (function prim prim (>= prim prim))
-       eta_float_ge =
-         (function prim prim (>=. prim prim))
-       eta_string_ge =
-         (function prim prim
-           (caml_string_greaterequal prim prim))
-       eta_int32_ge =
-         (function prim prim (Int32.>= prim prim))
-       eta_int64_ge =
-         (function prim prim (Int64.>= prim prim))
-       eta_nativeint_ge =
-         (function prim prim (Nativeint.>= prim prim))
-       int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
-       bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
-       intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
-       float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
-       string_vec =
-         [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
-       int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
-       int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
-       nativeint_vec =
-         [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
-       test_vec =
-         (function cmp eq ne lt gt le ge
-           vec
-           (let
-             (uncurry =
-                (function f param
-                  (apply f (field 0 param) (field 1 param)))
-              map =
-                (function f l
-                  (apply (field 12 (global List!))
-                    (apply uncurry f) l)))
-             (makeblock 0
-               (makeblock 0 (apply map gen_cmp vec)
-                 (apply map cmp vec))
-               (apply map
-                 (function gen spec
-                   (makeblock 0 (apply map gen vec)
-                     (apply map spec vec)))
-                 (makeblock 0 (makeblock 0 gen_eq eq)
-                   (makeblock 0 (makeblock 0 gen_ne ne)
-                     (makeblock 0 (makeblock 0 gen_lt lt)
-                       (makeblock 0 (makeblock 0 gen_gt gt)
-                         (makeblock 0 (makeblock 0 gen_le le)
-                           (makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
-      (seq
-        (apply test_vec int_cmp int_eq int_ne int_lt
-          int_gt int_le int_ge int_vec)
-        (apply test_vec bool_cmp bool_eq bool_ne
-          bool_lt bool_gt bool_le bool_ge bool_vec)
-        (apply test_vec intlike_cmp intlike_eq intlike_ne
-          intlike_lt intlike_gt intlike_le intlike_ge
-          intlike_vec)
-        (apply test_vec float_cmp float_eq float_ne
-          float_lt float_gt float_le float_ge
-          float_vec)
-        (apply test_vec string_cmp string_eq string_ne
-          string_lt string_gt string_le string_ge
-          string_vec)
-        (apply test_vec int32_cmp int32_eq int32_ne
-          int32_lt int32_gt int32_le int32_ge
-          int32_vec)
-        (apply test_vec int64_cmp int64_eq int64_ne
-          int64_lt int64_gt int64_le int64_ge
-          int64_vec)
-        (apply test_vec nativeint_cmp nativeint_eq
-          nativeint_ne nativeint_lt nativeint_gt
-          nativeint_le nativeint_ge nativeint_vec)
-        (let
-          (eta_test_vec =
-             (function cmp eq ne lt gt le
-               ge vec
-               (let
-                 (uncurry =
-                    (function f param
-                      (apply f (field 0 param)
-                        (field 1 param)))
-                  map =
-                    (function f l
-                      (apply (field 12 (global List!))
-                        (apply uncurry f) l)))
-                 (makeblock 0
-                   (makeblock 0 (apply map eta_gen_cmp vec)
-                     (apply map cmp vec))
-                   (apply map
-                     (function gen spec
-                       (makeblock 0 (apply map gen vec)
-                         (apply map spec vec)))
-                     (makeblock 0 (makeblock 0 eta_gen_eq eq)
-                       (makeblock 0 (makeblock 0 eta_gen_ne ne)
-                         (makeblock 0 (makeblock 0 eta_gen_lt lt)
-                           (makeblock 0 (makeblock 0 eta_gen_gt gt)
+  (let
+    (gen_cmp = (function x y (caml_compare x y))
+     int_cmp = (function x y (caml_int_compare x y))
+     bool_cmp =
+       (function x y (caml_int_compare x y))
+     intlike_cmp =
+       (function x y (caml_int_compare x y))
+     float_cmp =
+       (function x y (caml_float_compare x y))
+     string_cmp =
+       (function x y (caml_string_compare x y))
+     int32_cmp =
+       (function x y (caml_int32_compare x y))
+     int64_cmp =
+       (function x y (caml_int64_compare x y))
+     nativeint_cmp =
+       (function x y (caml_nativeint_compare x y))
+     gen_eq = (function x y (caml_equal x y))
+     int_eq = (function x y (== x y))
+     bool_eq = (function x y (== x y))
+     intlike_eq = (function x y (== x y))
+     float_eq = (function x y (==. x y))
+     string_eq =
+       (function x y (caml_string_equal x y))
+     int32_eq = (function x y (Int32.== x y))
+     int64_eq = (function x y (Int64.== x y))
+     nativeint_eq =
+       (function x y (Nativeint.== x y))
+     gen_ne = (function x y (caml_notequal x y))
+     int_ne = (function x y (!= x y))
+     bool_ne = (function x y (!= x y))
+     intlike_ne = (function x y (!= x y))
+     float_ne = (function x y (!=. x y))
+     string_ne =
+       (function x y (caml_string_notequal x y))
+     int32_ne = (function x y (Int32.!= x y))
+     int64_ne = (function x y (Int64.!= x y))
+     nativeint_ne =
+       (function x y (Nativeint.!= x y))
+     gen_lt = (function x y (caml_lessthan x y))
+     int_lt = (function x y (< x y))
+     bool_lt = (function x y (< x y))
+     intlike_lt = (function x y (< x y))
+     float_lt = (function x y (<. x y))
+     string_lt =
+       (function x y (caml_string_lessthan x y))
+     int32_lt = (function x y (Int32.< x y))
+     int64_lt = (function x y (Int64.< x y))
+     nativeint_lt = (function x y (Nativeint.< x y))
+     gen_gt = (function x y (caml_greaterthan x y))
+     int_gt = (function x y (> x y))
+     bool_gt = (function x y (> x y))
+     intlike_gt = (function x y (> x y))
+     float_gt = (function x y (>. x y))
+     string_gt =
+       (function x y (caml_string_greaterthan x y))
+     int32_gt = (function x y (Int32.> x y))
+     int64_gt = (function x y (Int64.> x y))
+     nativeint_gt = (function x y (Nativeint.> x y))
+     gen_le = (function x y (caml_lessequal x y))
+     int_le = (function x y (<= x y))
+     bool_le = (function x y (<= x y))
+     intlike_le = (function x y (<= x y))
+     float_le = (function x y (<=. x y))
+     string_le =
+       (function x y (caml_string_lessequal x y))
+     int32_le = (function x y (Int32.<= x y))
+     int64_le = (function x y (Int64.<= x y))
+     nativeint_le =
+       (function x y (Nativeint.<= x y))
+     gen_ge = (function x y (caml_greaterequal x y))
+     int_ge = (function x y (>= x y))
+     bool_ge = (function x y (>= x y))
+     intlike_ge = (function x y (>= x y))
+     float_ge = (function x y (>=. x y))
+     string_ge =
+       (function x y (caml_string_greaterequal x y))
+     int32_ge = (function x y (Int32.>= x y))
+     int64_ge = (function x y (Int64.>= x y))
+     nativeint_ge =
+       (function x y (Nativeint.>= x y))
+     eta_gen_cmp =
+       (function prim prim (caml_compare prim prim))
+     eta_int_cmp =
+       (function prim prim (caml_int_compare prim prim))
+     eta_bool_cmp =
+       (function prim prim (caml_int_compare prim prim))
+     eta_intlike_cmp =
+       (function prim prim (caml_int_compare prim prim))
+     eta_float_cmp =
+       (function prim prim
+         (caml_float_compare prim prim))
+     eta_string_cmp =
+       (function prim prim
+         (caml_string_compare prim prim))
+     eta_int32_cmp =
+       (function prim prim
+         (caml_int32_compare prim prim))
+     eta_int64_cmp =
+       (function prim prim
+         (caml_int64_compare prim prim))
+     eta_nativeint_cmp =
+       (function prim prim
+         (caml_nativeint_compare prim prim))
+     eta_gen_eq =
+       (function prim prim (caml_equal prim prim))
+     eta_int_eq =
+       (function prim prim (== prim prim))
+     eta_bool_eq =
+       (function prim prim (== prim prim))
+     eta_intlike_eq =
+       (function prim prim (== prim prim))
+     eta_float_eq =
+       (function prim prim (==. prim prim))
+     eta_string_eq =
+       (function prim prim (caml_string_equal prim prim))
+     eta_int32_eq =
+       (function prim prim (Int32.== prim prim))
+     eta_int64_eq =
+       (function prim prim (Int64.== prim prim))
+     eta_nativeint_eq =
+       (function prim prim (Nativeint.== prim prim))
+     eta_gen_ne =
+       (function prim prim (caml_notequal prim prim))
+     eta_int_ne =
+       (function prim prim (!= prim prim))
+     eta_bool_ne =
+       (function prim prim (!= prim prim))
+     eta_intlike_ne =
+       (function prim prim (!= prim prim))
+     eta_float_ne =
+       (function prim prim (!=. prim prim))
+     eta_string_ne =
+       (function prim prim
+         (caml_string_notequal prim prim))
+     eta_int32_ne =
+       (function prim prim (Int32.!= prim prim))
+     eta_int64_ne =
+       (function prim prim (Int64.!= prim prim))
+     eta_nativeint_ne =
+       (function prim prim (Nativeint.!= prim prim))
+     eta_gen_lt =
+       (function prim prim (caml_lessthan prim prim))
+     eta_int_lt = (function prim prim (< prim prim))
+     eta_bool_lt =
+       (function prim prim (< prim prim))
+     eta_intlike_lt =
+       (function prim prim (< prim prim))
+     eta_float_lt =
+       (function prim prim (<. prim prim))
+     eta_string_lt =
+       (function prim prim
+         (caml_string_lessthan prim prim))
+     eta_int32_lt =
+       (function prim prim (Int32.< prim prim))
+     eta_int64_lt =
+       (function prim prim (Int64.< prim prim))
+     eta_nativeint_lt =
+       (function prim prim (Nativeint.< prim prim))
+     eta_gen_gt =
+       (function prim prim (caml_greaterthan prim prim))
+     eta_int_gt = (function prim prim (> prim prim))
+     eta_bool_gt =
+       (function prim prim (> prim prim))
+     eta_intlike_gt =
+       (function prim prim (> prim prim))
+     eta_float_gt =
+       (function prim prim (>. prim prim))
+     eta_string_gt =
+       (function prim prim
+         (caml_string_greaterthan prim prim))
+     eta_int32_gt =
+       (function prim prim (Int32.> prim prim))
+     eta_int64_gt =
+       (function prim prim (Int64.> prim prim))
+     eta_nativeint_gt =
+       (function prim prim (Nativeint.> prim prim))
+     eta_gen_le =
+       (function prim prim (caml_lessequal prim prim))
+     eta_int_le =
+       (function prim prim (<= prim prim))
+     eta_bool_le =
+       (function prim prim (<= prim prim))
+     eta_intlike_le =
+       (function prim prim (<= prim prim))
+     eta_float_le =
+       (function prim prim (<=. prim prim))
+     eta_string_le =
+       (function prim prim
+         (caml_string_lessequal prim prim))
+     eta_int32_le =
+       (function prim prim (Int32.<= prim prim))
+     eta_int64_le =
+       (function prim prim (Int64.<= prim prim))
+     eta_nativeint_le =
+       (function prim prim (Nativeint.<= prim prim))
+     eta_gen_ge =
+       (function prim prim (caml_greaterequal prim prim))
+     eta_int_ge =
+       (function prim prim (>= prim prim))
+     eta_bool_ge =
+       (function prim prim (>= prim prim))
+     eta_intlike_ge =
+       (function prim prim (>= prim prim))
+     eta_float_ge =
+       (function prim prim (>=. prim prim))
+     eta_string_ge =
+       (function prim prim
+         (caml_string_greaterequal prim prim))
+     eta_int32_ge =
+       (function prim prim (Int32.>= prim prim))
+     eta_int64_ge =
+       (function prim prim (Int64.>= prim prim))
+     eta_nativeint_ge =
+       (function prim prim (Nativeint.>= prim prim))
+     int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
+     bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
+     intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
+     float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
+     string_vec =
+       [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
+     int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
+     int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
+     nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
+     test_vec =
+       (function cmp eq ne lt gt le ge
+         vec
+         (let
+           (uncurry =
+              (function f param
+                (apply f (field 0 param) (field 1 param)))
+            map =
+              (function f l
+                (apply (field 12 (global List!)) (apply uncurry f)
+                  l)))
+           (makeblock 0
+             (makeblock 0 (apply map gen_cmp vec)
+               (apply map cmp vec))
+             (apply map
+               (function gen spec
+                 (makeblock 0 (apply map gen vec)
+                   (apply map spec vec)))
+               (makeblock 0 (makeblock 0 gen_eq eq)
+                 (makeblock 0 (makeblock 0 gen_ne ne)
+                   (makeblock 0 (makeblock 0 gen_lt lt)
+                     (makeblock 0 (makeblock 0 gen_gt gt)
+                       (makeblock 0 (makeblock 0 gen_le le)
+                         (makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
+    (seq
+      (apply test_vec int_cmp int_eq int_ne int_lt
+        int_gt int_le int_ge int_vec)
+      (apply test_vec bool_cmp bool_eq bool_ne
+        bool_lt bool_gt bool_le bool_ge bool_vec)
+      (apply test_vec intlike_cmp intlike_eq intlike_ne
+        intlike_lt intlike_gt intlike_le intlike_ge
+        intlike_vec)
+      (apply test_vec float_cmp float_eq float_ne
+        float_lt float_gt float_le float_ge
+        float_vec)
+      (apply test_vec string_cmp string_eq string_ne
+        string_lt string_gt string_le string_ge
+        string_vec)
+      (apply test_vec int32_cmp int32_eq int32_ne
+        int32_lt int32_gt int32_le int32_ge
+        int32_vec)
+      (apply test_vec int64_cmp int64_eq int64_ne
+        int64_lt int64_gt int64_le int64_ge
+        int64_vec)
+      (apply test_vec nativeint_cmp nativeint_eq
+        nativeint_ne nativeint_lt nativeint_gt
+        nativeint_le nativeint_ge nativeint_vec)
+      (let
+        (eta_test_vec =
+           (function cmp eq ne lt gt le ge
+             vec
+             (let
+               (uncurry =
+                  (function f param
+                    (apply f (field 0 param) (field 1 param)))
+                map =
+                  (function f l
+                    (apply (field 12 (global List!))
+                      (apply uncurry f) l)))
+               (makeblock 0
+                 (makeblock 0 (apply map eta_gen_cmp vec)
+                   (apply map cmp vec))
+                 (apply map
+                   (function gen spec
+                     (makeblock 0 (apply map gen vec)
+                       (apply map spec vec)))
+                   (makeblock 0 (makeblock 0 eta_gen_eq eq)
+                     (makeblock 0 (makeblock 0 eta_gen_ne ne)
+                       (makeblock 0 (makeblock 0 eta_gen_lt lt)
+                         (makeblock 0 (makeblock 0 eta_gen_gt gt)
+                           (makeblock 0 (makeblock 0 eta_gen_le le)
                              (makeblock 0
-                               (makeblock 0 eta_gen_le le)
-                               (makeblock 0
-                                 (makeblock 0 eta_gen_ge ge) 0a)))))))))))
-          (seq
-            (apply eta_test_vec eta_int_cmp eta_int_eq
-              eta_int_ne eta_int_lt eta_int_gt eta_int_le
-              eta_int_ge int_vec)
-            (apply eta_test_vec eta_bool_cmp eta_bool_eq
-              eta_bool_ne eta_bool_lt eta_bool_gt
-              eta_bool_le eta_bool_ge bool_vec)
-            (apply eta_test_vec eta_intlike_cmp eta_intlike_eq
-              eta_intlike_ne eta_intlike_lt eta_intlike_gt
-              eta_intlike_le eta_intlike_ge intlike_vec)
-            (apply eta_test_vec eta_float_cmp eta_float_eq
-              eta_float_ne eta_float_lt eta_float_gt
-              eta_float_le eta_float_ge float_vec)
-            (apply eta_test_vec eta_string_cmp eta_string_eq
-              eta_string_ne eta_string_lt eta_string_gt
-              eta_string_le eta_string_ge string_vec)
-            (apply eta_test_vec eta_int32_cmp eta_int32_eq
-              eta_int32_ne eta_int32_lt eta_int32_gt
-              eta_int32_le eta_int32_ge int32_vec)
-            (apply eta_test_vec eta_int64_cmp eta_int64_eq
-              eta_int64_ne eta_int64_lt eta_int64_gt
-              eta_int64_le eta_int64_ge int64_vec)
-            (apply eta_test_vec eta_nativeint_cmp
-              eta_nativeint_eq eta_nativeint_ne
-              eta_nativeint_lt eta_nativeint_gt
-              eta_nativeint_le eta_nativeint_ge nativeint_vec)
-            (makeblock 0 gen_cmp int_cmp bool_cmp
-              intlike_cmp float_cmp string_cmp int32_cmp
-              int64_cmp nativeint_cmp gen_eq int_eq
-              bool_eq intlike_eq float_eq string_eq
-              int32_eq int64_eq nativeint_eq gen_ne
-              int_ne bool_ne intlike_ne float_ne
-              string_ne int32_ne int64_ne nativeint_ne
-              gen_lt int_lt bool_lt intlike_lt
-              float_lt string_lt int32_lt int64_lt
-              nativeint_lt gen_gt int_gt bool_gt
-              intlike_gt float_gt string_gt int32_gt
-              int64_gt nativeint_gt gen_le int_le
-              bool_le intlike_le float_le string_le
-              int32_le int64_le nativeint_le gen_ge
-              int_ge bool_ge intlike_ge float_ge
-              string_ge int32_ge int64_ge nativeint_ge
-              eta_gen_cmp eta_int_cmp eta_bool_cmp
-              eta_intlike_cmp eta_float_cmp eta_string_cmp
-              eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
-              eta_gen_eq eta_int_eq eta_bool_eq
-              eta_intlike_eq eta_float_eq eta_string_eq
-              eta_int32_eq eta_int64_eq eta_nativeint_eq
-              eta_gen_ne eta_int_ne eta_bool_ne
-              eta_intlike_ne eta_float_ne eta_string_ne
-              eta_int32_ne eta_int64_ne eta_nativeint_ne
-              eta_gen_lt eta_int_lt eta_bool_lt
-              eta_intlike_lt eta_float_lt eta_string_lt
-              eta_int32_lt eta_int64_lt eta_nativeint_lt
-              eta_gen_gt eta_int_gt eta_bool_gt
-              eta_intlike_gt eta_float_gt eta_string_gt
-              eta_int32_gt eta_int64_gt eta_nativeint_gt
-              eta_gen_le eta_int_le eta_bool_le
-              eta_intlike_le eta_float_le eta_string_le
-              eta_int32_le eta_int64_le eta_nativeint_le
-              eta_gen_ge eta_int_ge eta_bool_ge
-              eta_intlike_ge eta_float_ge eta_string_ge
-              eta_int32_ge eta_int64_ge eta_nativeint_ge
-              int_vec bool_vec intlike_vec float_vec
-              string_vec int32_vec int64_vec
-              nativeint_vec test_vec eta_test_vec)))))))
+                               (makeblock 0 eta_gen_ge ge) 0a)))))))))))
+        (seq
+          (apply eta_test_vec eta_int_cmp eta_int_eq
+            eta_int_ne eta_int_lt eta_int_gt eta_int_le
+            eta_int_ge int_vec)
+          (apply eta_test_vec eta_bool_cmp eta_bool_eq
+            eta_bool_ne eta_bool_lt eta_bool_gt
+            eta_bool_le eta_bool_ge bool_vec)
+          (apply eta_test_vec eta_intlike_cmp eta_intlike_eq
+            eta_intlike_ne eta_intlike_lt eta_intlike_gt
+            eta_intlike_le eta_intlike_ge intlike_vec)
+          (apply eta_test_vec eta_float_cmp eta_float_eq
+            eta_float_ne eta_float_lt eta_float_gt
+            eta_float_le eta_float_ge float_vec)
+          (apply eta_test_vec eta_string_cmp eta_string_eq
+            eta_string_ne eta_string_lt eta_string_gt
+            eta_string_le eta_string_ge string_vec)
+          (apply eta_test_vec eta_int32_cmp eta_int32_eq
+            eta_int32_ne eta_int32_lt eta_int32_gt
+            eta_int32_le eta_int32_ge int32_vec)
+          (apply eta_test_vec eta_int64_cmp eta_int64_eq
+            eta_int64_ne eta_int64_lt eta_int64_gt
+            eta_int64_le eta_int64_ge int64_vec)
+          (apply eta_test_vec eta_nativeint_cmp
+            eta_nativeint_eq eta_nativeint_ne eta_nativeint_lt
+            eta_nativeint_gt eta_nativeint_le eta_nativeint_ge
+            nativeint_vec)
+          (makeblock 0 gen_cmp int_cmp bool_cmp
+            intlike_cmp float_cmp string_cmp int32_cmp
+            int64_cmp nativeint_cmp gen_eq int_eq
+            bool_eq intlike_eq float_eq string_eq
+            int32_eq int64_eq nativeint_eq gen_ne
+            int_ne bool_ne intlike_ne float_ne
+            string_ne int32_ne int64_ne nativeint_ne
+            gen_lt int_lt bool_lt intlike_lt
+            float_lt string_lt int32_lt int64_lt
+            nativeint_lt gen_gt int_gt bool_gt
+            intlike_gt float_gt string_gt int32_gt
+            int64_gt nativeint_gt gen_le int_le
+            bool_le intlike_le float_le string_le
+            int32_le int64_le nativeint_le gen_ge
+            int_ge bool_ge intlike_ge float_ge
+            string_ge int32_ge int64_ge nativeint_ge
+            eta_gen_cmp eta_int_cmp eta_bool_cmp
+            eta_intlike_cmp eta_float_cmp eta_string_cmp
+            eta_int32_cmp eta_int64_cmp eta_nativeint_cmp
+            eta_gen_eq eta_int_eq eta_bool_eq
+            eta_intlike_eq eta_float_eq eta_string_eq
+            eta_int32_eq eta_int64_eq eta_nativeint_eq
+            eta_gen_ne eta_int_ne eta_bool_ne
+            eta_intlike_ne eta_float_ne eta_string_ne
+            eta_int32_ne eta_int64_ne eta_nativeint_ne
+            eta_gen_lt eta_int_lt eta_bool_lt
+            eta_intlike_lt eta_float_lt eta_string_lt
+            eta_int32_lt eta_int64_lt eta_nativeint_lt
+            eta_gen_gt eta_int_gt eta_bool_gt
+            eta_intlike_gt eta_float_gt eta_string_gt
+            eta_int32_gt eta_int64_gt eta_nativeint_gt
+            eta_gen_le eta_int_le eta_bool_le
+            eta_intlike_le eta_float_le eta_string_le
+            eta_int32_le eta_int64_le eta_nativeint_le
+            eta_gen_ge eta_int_ge eta_bool_ge
+            eta_intlike_ge eta_float_ge eta_string_ge
+            eta_int32_ge eta_int64_ge eta_nativeint_ge
+            int_vec bool_vec intlike_vec float_vec
+            string_vec int32_vec int64_vec nativeint_vec
+            test_vec eta_test_vec))))))

diff --git a/testsuite/tests/translprim/ref_spec.ml.reference b/testsuite/tests/translprim/ref_spec.ml.reference
index ed1784add8268c5176c36bb79462bc437139fe12..c21b100b9070c2b13ced38fc3885554abe7706ab 100644 (file)
--- a/testsuite/tests/translprim/ref_spec.ml.reference
+++ b/testsuite/tests/translprim/ref_spec.ml.reference
@@ -1,23 +1,23 @@
 (setglobal Ref_spec!
   (let
-    (int_ref = (makemutable 0 1)
+    (int_ref = (makemutable 0 (int) 1)
      var_ref = (makemutable 0 65a)
      vargen_ref = (makemutable 0 65a)
      cst_ref = (makemutable 0 0a)
      gen_ref = (makemutable 0 0a)
-     flt_ref = (makemutable 0 0.))
+     flt_ref = (makemutable 0 (float) 0.))
     (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a)
       (setfield_ptr 0 vargen_ref [0: 66 0])
       (setfield_ptr 0 vargen_ref 67a) (setfield_imm 0 cst_ref 1a)
       (setfield_ptr 0 gen_ref [0: "foo"])
       (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.)
       (let
-        (int_rec = (makemutable 0 0a 1)
+        (int_rec = (makemutable 0 (*,int) 0a 1)
          var_rec = (makemutable 0 0a 65a)
          vargen_rec = (makemutable 0 0a 65a)
          cst_rec = (makemutable 0 0a 0a)
          gen_rec = (makemutable 0 0a 0a)
-         flt_rec = (makemutable 0 0a 0.)
+         flt_rec = (makemutable 0 (*,float) 0a 0.)
          flt_rec' = (makearray[float] 0. 0.))
         (seq (setfield_imm 1 int_rec 2)
           (setfield_imm 1 var_rec 66a)

diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml
index 766bee0434542a3188dc6c68a5df5545f8cf0d95..c439f38ae660d182b87836c4b7f0d2cb5ba8e894 100644 (file)
--- a/testsuite/tests/typing-extensions/open_types.ml
+++ b/testsuite/tests/typing-extensions/open_types.ml
@@ -115,3 +115,11 @@ let f = function
   | _::_::_ -> 3
   | [] -> 2
 ;; (* warn *)
+
+
+(* PR#7330: exhaustiveness with GADTs *)
+
+type t = ..
+type t += IPair : (int * int) -> t ;;
+
+let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)

diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference
index 8e86ec09378859ad1f0ee929ab3e4cedabc33087..a339ac7ff39b83b14763a686cef34c38b08f66fc 100644 (file)
--- a/testsuite/tests/typing-extensions/open_types.ml.reference
+++ b/testsuite/tests/typing-extensions/open_types.ml.reference
@@ -75,7 +75,7 @@ Error: Signature mismatch:
   let f = function Foo -> ()
           ^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 *extension*
 Matching over values of extensible variant types (the *extension* above)
 must include a wild card pattern in order to be exhaustive.
@@ -88,9 +88,20 @@ val f : foo -> unit = <fun>
     | _::_::_ -> 3
     | [] -> 2
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 *extension*::[]
 Matching over values of extensible variant types (the *extension* above)
 must include a wild card pattern in order to be exhaustive.
 val f : foo list -> int = <fun>
+#           type t = ..
+type t += IPair : (int * int) -> t
+#   Characters 9-63:
+  let f = function IPair (i, j) -> Format.sprintf "(%d, %d)" i j ;; (* warn *)
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+*extension*
+Matching over values of extensible variant types (the *extension* above)
+must include a wild card pattern in order to be exhaustive.
+val f : t -> string = <fun>
 # 

diff --git a/testsuite/tests/typing-gadts/Makefile b/testsuite/tests/typing-gadts/Makefile
index 7fc00661cbe83513fbab37e2fe27d89365c35054..0b15e777de9b37e51d0594072c80e3eef907fd3e 100644 (file)
--- a/testsuite/tests/typing-gadts/Makefile
+++ b/testsuite/tests/typing-gadts/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-gadts/didier.ml b/testsuite/tests/typing-gadts/didier.ml
index f34ecb678da9de1e2bbb2b82a1767fc1a2e0c326..cab57d2ba21567217ab3241b683826f28b927e2c 100644 (file)
--- a/testsuite/tests/typing-gadts/didier.ml
+++ b/testsuite/tests/typing-gadts/didier.ml
@@ -6,6 +6,14 @@ let fbool (type t) (x : t) (tag : t ty) =
   match tag with
   | Bool -> x
 ;;
+[%%expect{|
+type 'a ty = Int : int ty | Bool : bool ty
+Line _, characters 2-30:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Int
+val fbool : 'a -> 'a ty -> 'a = <fun>
+|}];;
 (* val fbool : 'a -> 'a ty -> 'a = <fun> *)
 (** OK: the return value is x of type t **)
 
@@ -13,24 +21,58 @@ let fint (type t) (x : t) (tag : t ty) =
   match tag with
   | Int -> x > 0
 ;;
+[%%expect{|
+Line _, characters 2-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Bool
+val fint : 'a -> 'a ty -> bool = <fun>
+|}];;
 (* val fint : 'a -> 'a ty -> bool = <fun> *)
 (** OK: the return value is x > 0 of type bool;
 This has used the equation t = bool, not visible in the return type **)
 
+(* not principal *)
 let f (type t) (x : t) (tag : t ty) =
   match tag with
   | Int -> x > 0
   | Bool -> x
+;;
+[%%expect{|
+val f : 'a -> 'a ty -> bool = <fun>
+|}, Principal{|
+Line _, characters 12-13:
+Error: This expression has type t but an expression was expected of type bool
+|}];;
 (* val f : 'a -> 'a ty -> bool = <fun> *)
 
-
+(* fail for both *)
 let g (type t) (x : t) (tag : t ty) =
   match tag with
   | Bool -> x
   | Int -> x > 0
+;;
+[%%expect{|
+Line _, characters 11-16:
+Error: This expression has type bool but an expression was expected of type
+         t = int
+|}, Principal{|
+Line _, characters 11-16:
+Error: This expression has type bool but an expression was expected of type t
+|}];;
 (* Error: This expression has type bool but an expression was expected of type
 t = int *)
 
+(* OK *)
+let g (type t) (x : t) (tag : t ty) : bool =
+  match tag with
+  | Bool -> x
+  | Int -> x > 0
+;;
+[%%expect{|
+val g : 'a -> 'a ty -> bool = <fun>
+|}];;
+
 let id x = x;;
 let idb1 = (fun id -> let _ = id true in id) id;;
 let idb2 : bool -> bool = id;;
@@ -40,8 +82,20 @@ let g (type t) (x : t) (tag : t ty) =
   match tag with
   | Bool -> idb3 x
   | Int -> x > 0
+;;
+[%%expect{|
+val id : 'a -> 'a = <fun>
+val idb1 : bool -> bool = <fun>
+val idb2 : bool -> bool = <fun>
+val idb3 : bool -> bool = <fun>
+val g : 'a -> 'a ty -> bool = <fun>
+|}];;
 
 let g (type t) (x : t) (tag : t ty) =
   match tag with
   | Bool -> idb2 x
   | Int -> x > 0
+;;
+[%%expect{|
+val g : 'a -> 'a ty -> bool = <fun>
+|}];;

diff --git a/testsuite/tests/typing-gadts/didier.ml.reference b/testsuite/tests/typing-gadts/didier.ml.reference
deleted file mode 100644 (file)
index 295d38b..0000000
--- a/testsuite/tests/typing-gadts/didier.ml.reference
+++ /dev/null
@@ -1,34 +0,0 @@
-
-#               Characters 94-122:
-  ..match tag with
-    | Bool -> x
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Int
-type 'a ty = Int : int ty | Bool : bool ty
-val fbool : 'a -> 'a ty -> 'a = <fun>
-#             Characters 132-163:
-  ..match tag with
-    | Int -> x > 0
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Bool
-val fint : 'a -> 'a ty -> bool = <fun>
-#   *                           *     Characters 376-381:
-    | Int -> x > 0
-             ^^^^^
-Error: This expression has type bool but an expression was expected of type
-         t = int
-# Characters 45-47:
-  let idb1 = (fun id -> let _ = id true in id) id;;
-                                               ^^
-Error: Unbound value id
-# Characters 26-28:
-  let idb2 : bool -> bool = id;;
-                            ^^
-Error: Unbound value id
-# val idb3 : bool -> bool = <fun>
-#                     
-Characters 184-184:
-  Error: Syntax error
-# 

diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml b/testsuite/tests/typing-gadts/dynamic_frisch.ml
index 7018bbc156b7fdf7e7c4c4b66bab5849ef246273..112c161b6b84d4da9ebacd7cbd35e858f41390c5 100644 (file)
--- a/testsuite/tests/typing-gadts/dynamic_frisch.ml
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml
@@ -18,6 +18,7 @@ type variant =
   | VString of string
   | VList of variant list
   | VPair of variant * variant
+;;
 
 let rec variantize: type t. t ty -> t -> variant =
   fun ty x ->
@@ -31,8 +32,23 @@ let rec variantize: type t. t ty -> t -> variant =
     | Pair (ty1, ty2) ->
         VPair (variantize ty1 (fst x), variantize ty2 (snd x))
         (* t = ('a, 'b) for some 'a and 'b *)
+;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+val variantize : 't ty -> 't -> variant = <fun>
+|}];;
 
 exception VariantMismatch
+;;
 
 let rec devariantize: type t. t ty -> variant -> t =
   fun ty v ->
@@ -45,6 +61,10 @@ let rec devariantize: type t. t ty -> variant -> t =
         (devariantize ty1 x1, devariantize ty2 x2)
     | _ -> raise VariantMismatch
 ;;
+[%%expect{|
+exception VariantMismatch
+val devariantize : 't ty -> variant -> 't = <fun>
+|}];;
 
 (* Handling records *)
 
@@ -80,6 +100,7 @@ type variant =
   | VList of variant list
   | VPair of variant * variant
   | VRecord of (string * variant) list
+;;
 
 let rec variantize: type t. t ty -> t -> variant =
   fun ty x ->
@@ -98,6 +119,24 @@ let rec variantize: type t. t ty -> t -> variant =
           (List.map (fun (Field{field_type; label; get}) ->
                        (label, variantize field_type (get x))) fields)
 ;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : 'a record -> 'a ty
+and 'a record = { path : string; fields : 'a field_ list; }
+and 'a field_ = Field : ('a, 'b) field -> 'a field_
+and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+val variantize : 't ty -> 't -> variant = <fun>
+|}];;
 
 (* Extraction *)
 
@@ -126,6 +165,7 @@ and ('a, 'builder, 'b) field_ =
    get: ('a -> 'b);
    set: ('builder -> 'b -> unit);
   }
+;;
 
 let rec devariantize: type t. t ty -> variant -> t =
   fun ty v ->
@@ -148,12 +188,36 @@ let rec devariantize: type t. t ty -> variant -> t =
         of_builder builder
     | _ -> raise VariantMismatch
 ;;
+[%%expect{|
+type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : ('a, 'builder) record -> 'a ty
+and ('a, 'builder) record = {
+  path : string;
+  fields : ('a, 'builder) field list;
+  create_builder : unit -> 'builder;
+  of_builder : 'builder -> 'a;
+}
+and ('a, 'builder) field =
+    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+and ('a, 'builder, 'b) field_ = {
+  label : string;
+  field_type : 'b ty;
+  get : 'a -> 'b;
+  set : 'builder -> 'b -> unit;
+}
+val devariantize : 't ty -> variant -> 't = <fun>
+|}];;
 
 type my_record  =
     {
      a: int;
      b: string list;
     }
+;;
 
 let my_record =
   let fields =
@@ -174,6 +238,16 @@ let my_record =
   in
   Record {path = "My_module.my_record"; fields; create_builder; of_builder}
 ;;
+[%%expect{|
+type my_record = { a : int; b : string list; }
+val my_record : my_record ty =
+  Record
+   {path = "My_module.my_record";
+    fields =
+     [Field {label = "a"; field_type = Int; get = <fun>; set = <fun>};
+      Field {label = "b"; field_type = List String; get = <fun>; set = <fun>}];
+    create_builder = <fun>; of_builder = <fun>}
+|}];;
 
 (* Extension to recursive types and polymorphic variants *)
 (* by Jacques Garrigue *)
@@ -219,6 +293,7 @@ type _ ty_env =              (* type variable substitution *)
 
 (* Comparing selectors *)
 type (_,_) eq = Eq: ('a,'a) eq
+;;
 
 let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
   fun s1 s2 ->
@@ -227,6 +302,38 @@ let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
     | Ttl s1, Ttl s2 ->
         (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq)
     | _ -> None
+;;
+[%%expect{|
+type noarg = Noarg
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+and ('a, 'e, 'b) ty_sum = {
+  sum_proj : 'a -> string * 'e ty_dyn option;
+  sum_cases : (string * ('e, 'b) ty_case) list;
+  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+}
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+type _ ty_env =
+    Enil : unit ty_env
+  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+type (_, _) eq = Eq : ('a, 'a) eq
+val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = <fun>
+|}];;
 
 (* Auxiliary function to get the type of a case from its selector *)
 let rec get_case : type a b e.
@@ -245,6 +352,11 @@ let rec get_case : type a b e.
       end
   | [] -> raise Not_found
 ;;
+[%%expect{|
+val get_case :
+  ('b, 'a) ty_sel ->
+  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = <fun>
+|}];;
 
 (* Untyped representation of values *)
 type variant =
@@ -255,8 +367,9 @@ type variant =
   | VPair of variant * variant
   | VConv of string * variant
   | VSum of string * variant option
+;;
 
-let may_map f = function Some x -> Some (f x) | None -> None
+let may_map f = function Some x -> Some (f x) | None -> None ;;
 
 let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
   fun e ty v ->
@@ -274,6 +387,18 @@ let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
       let tag, arg = ops.sum_proj v in
       VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg)
 ;;
+[%%expect{|
+type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+val may_map : ('a -> 'b) -> 'a option -> 'b option = <fun>
+val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = <fun>
+|}];;
 
 let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
   fun e ty v ->
@@ -298,21 +423,51 @@ let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
       end
   | _ -> raise VariantMismatch
 ;;
+[%%expect{|
+val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = <fun>
+|}];;
 
 (* First attempt: represent 1-constructor variants using Conv *)
 let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);;
+[%%expect{|
+val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = <fun>
+|}];;
 
 let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;;
+[%%expect{|
+val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
+  <fun>
+|}];;
 let v = variantize Enil (ty Int);;
+[%%expect{|
+val v : ([ `A of (int * 'a) option ] as 'a) -> variant = <fun>
+|}];;
 let x = v (`A (Some (1, `A (Some (2, `A None))))) ;;
+[%%expect{|
+val x : variant =
+  VConv ("`A",
+   VOption
+    (Some
+      (VPair (VInt 1,
+        VConv ("`A",
+         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
+|}];;
 
 (* Can also use it to decompose a tuple *)
 
 let triple t1 t2 t3 =
   Conv ("Triple", (fun (a,b,c) -> (a,(b,c))),
-        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)))
+        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)));;
+[%%expect{|
+val triple :
+  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = <fun>
+|}];;
 
 let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;;
+[%%expect{|
+val v : variant =
+  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
+|}];;
 
 (* Second attempt: introduce a real sum construct *)
 let ty_abc =
@@ -333,12 +488,28 @@ let ty_abc =
         [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
           "C", TCnoarg (Ttl (Ttl Thd)) ] }
 ;;
-
-let v = variantize Enil ty_abc (`A 3)
-let a = devariantize Enil ty_abc v
+[%%expect{|
+val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
+  Sum
+   {sum_proj = <fun>;
+    sum_cases =
+     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
+      ("C", TCnoarg (Ttl (Ttl Thd)))];
+    sum_inj = <fun>}
+|}];;
+
+let v = variantize Enil ty_abc (`A 3);;
+[%%expect{|
+val v : variant = VSum ("A", Some (VInt 3))
+|}];;
+let a = devariantize Enil ty_abc v;;
+[%%expect{|
+val a : [ `A of int | `B of string | `C ] = `A 3
+|}];;
 
 (* And an example with recursion... *)
 type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+;;
 
 let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
   let tcons = Pair (Pop t, Var) in
@@ -354,9 +525,19 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
          : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)
          (* One can also write the type annotation directly *)
      })
+;;
+[%%expect{|
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
+|}];;
 
 let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;;
-
+[%%expect{|
+val v : variant =
+  VSum ("Cons",
+   Some
+    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
+|}];;
 
 (* Simpler but weaker approach *)
 
@@ -374,6 +555,7 @@ type (_,_) ty =
              -> ('a, 'e) ty
 and 'e ty_dyn =
   | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+;;
 
 let ty_abc : ([`A of int | `B of string | `C],'e) ty =
   (* Could also use [get_case] for proj, but direct definition is shorter *)
@@ -388,6 +570,22 @@ let ty_abc : ([`A of int | `B of string | `C],'e) ty =
     | "C", None -> `C
     | _ -> invalid_arg "ty_abc"))
 ;;
+[%%expect{|
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a -> string * 'e ty_dyn option) *
+      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>)
+|}];;
 
 (* Breaks: no way to pattern-match on a full recursive type *)
 let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
@@ -398,6 +596,13 @@ let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
   (function "Nil", None -> `Nil
     | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
 ;;
+[%%expect{|
+Line _, characters 41-58:
+Error: This pattern matches values of type a * a vlist
+       but a pattern was expected which matches values of type
+         $Tdyn_'a = $0 * $1
+       Type a is not compatible with type $0
+|}];;
 
 (* Define Sum using object instead of record for first-class polymorphism *)
 
@@ -445,8 +650,34 @@ let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty =
       | Ttl Thd, v -> `B v
       | Ttl (Ttl Thd), Noarg -> `C
   end)
+;;
+[%%expect{|
+type (_, _) ty =
+    Int : (int, 'd) ty
+  | String : (string, 'f) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum :
+      < cases : (string * ('e, 'b) ty_case) list;
+        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum <obj>
+|}];;
 
 type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+;;
 
 let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
   let tcons = Pair (Pop t, Var) in
@@ -461,6 +692,10 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
       | Ttl Thd, v -> `Cons v
   end))
 ;;
+[%%expect{|
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
+|}];;
 
 (*
 type (_,_) ty_assoc =

diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
deleted file mode 100644 (file)
index 894b553..0000000
--- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
+++ /dev/null
@@ -1,177 +0,0 @@
-
-#                       type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-#                                                                     type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VPair of variant * variant
-val variantize : 't ty -> 't -> variant = <fun>
-exception VariantMismatch
-val devariantize : 't ty -> variant -> 't = <fun>
-#                                                   type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-  | Record : 'a record -> 'a ty
-and 'a record = { path : string; fields : 'a field_ list; }
-and 'a field_ = Field : ('a, 'b) field -> 'a field_
-and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
-#                                                     type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VPair of variant * variant
-  | VRecord of (string * variant) list
-val variantize : 't ty -> 't -> variant = <fun>
-#                                                                                                   type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-  | Record : ('a, 'builder) record -> 'a ty
-and ('a, 'builder) record = {
-  path : string;
-  fields : ('a, 'builder) field list;
-  create_builder : unit -> 'builder;
-  of_builder : 'builder -> 'a;
-}
-and ('a, 'builder) field =
-    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
-and ('a, 'builder, 'b) field_ = {
-  label : string;
-  field_type : 'b ty;
-  get : 'a -> 'b;
-  set : 'builder -> 'b -> unit;
-}
-val devariantize : 't ty -> variant -> 't = <fun>
-#                                                   type my_record = { a : int; b : string list; }
-val my_record : my_record ty =
-  Record
-   {path = "My_module.my_record";
-    fields =
-     [Field {label = "a"; field_type = Int; get = <fun>; set = <fun>};
-      Field {label = "b"; field_type = List String; get = <fun>; set = <fun>}];
-    create_builder = <fun>; of_builder = <fun>}
-#                                                                         type noarg = Noarg
-type (_, _) ty =
-    Int : (int, 'c) ty
-  | String : (string, 'd) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
-and ('a, 'e, 'b) ty_sum = {
-  sum_proj : 'a -> string * 'e ty_dyn option;
-  sum_cases : (string * ('e, 'b) ty_case) list;
-  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
-}
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-and (_, _) ty_sel =
-    Thd : ('a -> 'b, 'a) ty_sel
-  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
-and (_, _) ty_case =
-    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
-  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
-#         type _ ty_env =
-    Enil : unit ty_env
-  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
-#                                                         type (_, _) eq = Eq : ('a, 'a) eq
-val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = <fun>
-val get_case :
-  ('b, 'a) ty_sel ->
-  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = <fun>
-#                                                         type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VOption of variant option
-  | VPair of variant * variant
-  | VConv of string * variant
-  | VSum of string * variant option
-val may_map : ('a -> 'b) -> 'a option -> 'b option = <fun>
-val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = <fun>
-#                                               val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = <fun>
-#     val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = <fun>
-#   val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
-  <fun>
-# val v : ([ `A of (int * 'a) option ] as 'a) -> variant = <fun>
-# val x : variant =
-  VConv ("`A",
-   VOption
-    (Some
-      (VPair (VInt 1,
-        VConv ("`A",
-         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
-#               val triple :
-  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = <fun>
-val v : variant =
-  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
-#                                       val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
-  Sum
-   {sum_proj = <fun>;
-    sum_cases =
-     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
-      ("C", TCnoarg (Ttl (Ttl Thd)))];
-    sum_inj = <fun>}
-#                                             val a : [ `A of int | `B of string | `C ] = `A 3
-type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
-val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
-val v : variant =
-  VSum ("Cons",
-   Some
-    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
-#                                                               type (_, _) ty =
-    Int : (int, 'c) ty
-  | String : (string, 'd) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum : ('a -> string * 'e ty_dyn option) *
-      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>)
-#                   Characters 327-344:
-      | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
-                                           ^^^^^^^^^^^^^^^^^
-Error: This pattern matches values of type a * a vlist
-       but a pattern was expected which matches values of type
-         $Tdyn_'a = $0 * $1
-       Type a is not compatible with type $0 
-#                                                         type (_, _) ty =
-    Int : (int, 'd) ty
-  | String : (string, 'f) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum :
-      < cases : (string * ('e, 'b) ty_case) list;
-        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
-        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-and (_, _) ty_sel =
-    Thd : ('a -> 'b, 'a) ty_sel
-  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
-and (_, _) ty_case =
-    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
-  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
-#                                                                   val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum <obj>
-type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
-val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
-#   * * * * * * * * *   

diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
deleted file mode 100644 (file)
index 894b553..0000000
--- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
+++ /dev/null
@@ -1,177 +0,0 @@
-
-#                       type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-#                                                                     type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VPair of variant * variant
-val variantize : 't ty -> 't -> variant = <fun>
-exception VariantMismatch
-val devariantize : 't ty -> variant -> 't = <fun>
-#                                                   type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-  | Record : 'a record -> 'a ty
-and 'a record = { path : string; fields : 'a field_ list; }
-and 'a field_ = Field : ('a, 'b) field -> 'a field_
-and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
-#                                                     type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VPair of variant * variant
-  | VRecord of (string * variant) list
-val variantize : 't ty -> 't -> variant = <fun>
-#                                                                                                   type 'a ty =
-    Int : int ty
-  | String : string ty
-  | List : 'a ty -> 'a list ty
-  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-  | Record : ('a, 'builder) record -> 'a ty
-and ('a, 'builder) record = {
-  path : string;
-  fields : ('a, 'builder) field list;
-  create_builder : unit -> 'builder;
-  of_builder : 'builder -> 'a;
-}
-and ('a, 'builder) field =
-    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
-and ('a, 'builder, 'b) field_ = {
-  label : string;
-  field_type : 'b ty;
-  get : 'a -> 'b;
-  set : 'builder -> 'b -> unit;
-}
-val devariantize : 't ty -> variant -> 't = <fun>
-#                                                   type my_record = { a : int; b : string list; }
-val my_record : my_record ty =
-  Record
-   {path = "My_module.my_record";
-    fields =
-     [Field {label = "a"; field_type = Int; get = <fun>; set = <fun>};
-      Field {label = "b"; field_type = List String; get = <fun>; set = <fun>}];
-    create_builder = <fun>; of_builder = <fun>}
-#                                                                         type noarg = Noarg
-type (_, _) ty =
-    Int : (int, 'c) ty
-  | String : (string, 'd) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
-and ('a, 'e, 'b) ty_sum = {
-  sum_proj : 'a -> string * 'e ty_dyn option;
-  sum_cases : (string * ('e, 'b) ty_case) list;
-  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
-}
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-and (_, _) ty_sel =
-    Thd : ('a -> 'b, 'a) ty_sel
-  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
-and (_, _) ty_case =
-    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
-  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
-#         type _ ty_env =
-    Enil : unit ty_env
-  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
-#                                                         type (_, _) eq = Eq : ('a, 'a) eq
-val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = <fun>
-val get_case :
-  ('b, 'a) ty_sel ->
-  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = <fun>
-#                                                         type variant =
-    VInt of int
-  | VString of string
-  | VList of variant list
-  | VOption of variant option
-  | VPair of variant * variant
-  | VConv of string * variant
-  | VSum of string * variant option
-val may_map : ('a -> 'b) -> 'a option -> 'b option = <fun>
-val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = <fun>
-#                                               val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = <fun>
-#     val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = <fun>
-#   val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
-  <fun>
-# val v : ([ `A of (int * 'a) option ] as 'a) -> variant = <fun>
-# val x : variant =
-  VConv ("`A",
-   VOption
-    (Some
-      (VPair (VInt 1,
-        VConv ("`A",
-         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
-#               val triple :
-  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = <fun>
-val v : variant =
-  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
-#                                       val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
-  Sum
-   {sum_proj = <fun>;
-    sum_cases =
-     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
-      ("C", TCnoarg (Ttl (Ttl Thd)))];
-    sum_inj = <fun>}
-#                                             val a : [ `A of int | `B of string | `C ] = `A 3
-type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
-val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
-val v : variant =
-  VSum ("Cons",
-   Some
-    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
-#                                                               type (_, _) ty =
-    Int : (int, 'c) ty
-  | String : (string, 'd) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum : ('a -> string * 'e ty_dyn option) *
-      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>)
-#                   Characters 327-344:
-      | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
-                                           ^^^^^^^^^^^^^^^^^
-Error: This pattern matches values of type a * a vlist
-       but a pattern was expected which matches values of type
-         $Tdyn_'a = $0 * $1
-       Type a is not compatible with type $0 
-#                                                         type (_, _) ty =
-    Int : (int, 'd) ty
-  | String : (string, 'f) ty
-  | List : ('a, 'e) ty -> ('a list, 'e) ty
-  | Option : ('a, 'e) ty -> ('a option, 'e) ty
-  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
-  | Var : ('a, 'a -> 'e) ty
-  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
-  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
-  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
-  | Sum :
-      < cases : (string * ('e, 'b) ty_case) list;
-        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
-        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
-and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
-and (_, _) ty_sel =
-    Thd : ('a -> 'b, 'a) ty_sel
-  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
-and (_, _) ty_case =
-    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
-  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
-#                                                                   val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum <obj>
-type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
-val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
-#   * * * * * * * * *   

diff --git a/testsuite/tests/typing-gadts/nested_equations.ml b/testsuite/tests/typing-gadts/nested_equations.ml
new file mode 100644 (file)
index 0000000..4039e35
--- /dev/null
+++ b/testsuite/tests/typing-gadts/nested_equations.ml
@@ -0,0 +1,84 @@
+(* Tests for nested equations (bind abstract types from other modules) *)
+
+type _ t = Int : int t;;
+
+let to_int (type a) (w : a t) (x : a) : int = let Int = w in x;;
+[%%expect{|
+type _ t = Int : int t
+val to_int : 'a t -> 'a -> int = <fun>
+|}];;
+
+let w_bool : bool t = Obj.magic 0;;
+let f_bool (x : bool) : int = let Int = w_bool in x;; (* fail *)
+[%%expect{|
+val w_bool : bool t = Int
+Line _, characters 34-37:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type bool t
+       Type int is not compatible with type bool
+|}];;
+
+let w_buffer : Buffer.t t = Obj.magic 0;;
+let f_buffer (x : Buffer.t) : int = let Int = w_buffer in x;; (* ok *)
+[%%expect{|
+val w_buffer : Buffer.t t = Int
+val f_buffer : Buffer.t -> int = <fun>
+|}];;
+
+let w_spec : Arg.spec t = Obj.magic 0;;
+let f_spec (x : Arg.spec) : int = let Int = w_spec in x;; (* fail *)
+[%%expect{|
+val w_spec : Arg.spec t = Int
+Line _, characters 38-41:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type Arg.spec t
+       Type int is not compatible with type Arg.spec
+|}];;
+
+module M : sig type u val w : u t val x : u end =
+  struct type u = int let w = Int let x = 33 end;;
+let m_x : int = let Int = M.w in M.x;;
+[%%expect{|
+module M : sig type u val w : u t val x : u end
+val m_x : int = 33
+|}];;
+
+module F (X : sig type u = int val x : u end) = struct let x : int = X.x end;;
+let fm_x : int = let Int = M.w in let module FM = F(M) in FM.x;; (* ok *)
+[%%expect{|
+module F :
+  functor (X : sig type u = int val x : u end) -> sig val x : int end
+val fm_x : int = 33
+|}];;
+
+module M' = struct module M : sig type u val w : u t val x : u end = M end;;
+module F' (X : sig module M : sig type u = int val x : u end end) =
+  struct let x : int = X.M.x end;;
+let fm'_x : int =
+  let Int = M'.M.w in let module FM' = F'(M') in FM'.x;; (* ok *)
+[%%expect{|
+module M' : sig module M : sig type u val w : u t val x : u end end
+module F' :
+  functor (X : sig module M : sig type u = int val x : u end end) ->
+    sig val x : int end
+val fm'_x : int = 33
+|}];;
+
+(* PR#7233 *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+module type S = sig
+  type t
+  val eql : (t, int) eq
+end
+
+module F (M : S) = struct
+  let zero : M.t =
+    let Refl = M.eql in 0
+end;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+module type S = sig type t val eql : (t, int) eq end
+module F : functor (M : S) -> sig val zero : M.t end
+|}];;

diff --git a/testsuite/tests/typing-gadts/omega07.ml b/testsuite/tests/typing-gadts/omega07.ml
index ddd7133cfd6a0a209fee898964ceba673fc0dde4..6c729abe8df8e7bde85b61d67a92662ee4f378c3 100644 (file)
--- a/testsuite/tests/typing-gadts/omega07.ml
+++ b/testsuite/tests/typing-gadts/omega07.ml
@@ -24,6 +24,16 @@ type (_,_) seq =
 ;;
 
 let l1 = Scons (3, Scons (5, Snil)) ;;
+[%%expect{|
+type ('a, 'b) sum = Inl of 'a | Inr of 'b
+type zero = Zero
+type 'a succ = Succ of 'a
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+type (_, _) seq =
+    Snil : ('a, zero) seq
+  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
+val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
+|}];;
 
 (* We do not have type level functions, so we need to use witnesses. *)
 (* We copy here the definitions from section 3.9 *)
@@ -38,6 +48,12 @@ let rec length : type a n. (a,n) seq -> n nat = function
   | Snil -> NZ
   | Scons (_, s) -> NS (length s)
 ;;
+[%%expect{|
+type (_, _, _) plus =
+    PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+val length : ('a, 'n) seq -> 'n nat = <fun>
+|}];;
 
 (* app returns the catenated lists with a witness proving that
    the size is the sum of its two inputs *)
@@ -51,6 +67,11 @@ let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
       let App (xs'', pl) = app xs' ys in
       App (Scons (x, xs''), PlusS pl)
 ;;
+[%%expect{|
+type (_, _, _) app =
+    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
+val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
+|}];;
 
 (* 3.1 Feature: kinds *)
 
@@ -86,6 +107,29 @@ type (_,_) tree =
 ;;
 let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
 ;;
+[%%expect{|
+type tp = TP
+type nd = ND
+type ('a, 'b) fk = FK
+type _ shape =
+    Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
+type tt = TT
+type ff = FF
+type _ boolean = BT : tt boolean | BF : ff boolean
+type (_, _) path =
+    Pnone : 'a -> (tp, 'a) path
+  | Phere : (nd, 'a) path
+  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
+  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
+type (_, _) tree =
+    Ttip : (tp, 'a) tree
+  | Tnode : 'a -> (nd, 'a) tree
+  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
+val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
+  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+|}];;
 let rec find : type sh.
     ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list
   = fun eq n t ->
@@ -97,6 +141,10 @@ let rec find : type sh.
         List.map (fun x -> Pleft x) (find eq n x) @
         List.map (fun x -> Pright x) (find eq n y)
 ;;
+[%%expect{|
+val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
+  <fun>
+|}];;
 let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
   match (p, t) with
   | Pnone x, Ttip -> x
@@ -104,6 +152,9 @@ let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
   | Pleft p, Tfork(l,_) -> extract p l
   | Pright p, Tfork(_,r) -> extract p r
 ;;
+[%%expect{|
+val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = <fun>
+|}];;
 
 (* 3.4 Pattern : Witness *)
 
@@ -126,17 +177,38 @@ let even4 : four even = EvenSS (EvenSS EvenZ)
 ;;
 let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
 ;;
+[%%expect{|
+type (_, _) le =
+    LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+val even0 : zero even = EvenZ
+val even2 : two even = EvenSS EvenZ
+val even4 : four even = EvenSS (EvenSS EvenZ)
+val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+|}];;
 let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p ->
   match p with
   | PlusZ n -> LeZ n
   | PlusS p' -> LeS (summandLessThanSum p')
 ;;
+[%%expect{|
+val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = <fun>
+|}];;
 
 (* 3.8 Pattern: Leibniz Equality *)
 
 type (_,_) equal = Eq : ('a,'a) equal
 
 let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x
+[%%expect{|
+type (_, _) equal = Eq : ('a, 'a) equal
+val convert : ('a, 'b) equal -> 'a -> 'b = <fun>
+|}];;
 
 let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
   match a, b with
@@ -148,6 +220,9 @@ let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
       end
   | _ -> None
 ;;
+[%%expect{|
+val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun>
+|}];;
 
 (* Extra: associativity of addition *)
 
@@ -158,6 +233,11 @@ let rec plus_func : type a b m n.
   | PlusZ _, PlusZ _ -> Eq
   | PlusS p1', PlusS p2' ->
       let Eq = plus_func p1' p2' in Eq
+;;
+[%%expect{|
+val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
+  <fun>
+|}];;
 
 let rec plus_assoc : type a b c ab bc m n.
   (a,b,ab) plus -> (ab,c,m) plus ->
@@ -169,6 +249,12 @@ let rec plus_assoc : type a b c ab bc m n.
       let PlusS p2' = p2 in
       let Eq = plus_assoc p1' p2' p3 p4' in Eq
 ;;
+[%%expect{|
+val plus_assoc :
+  ('a, 'b, 'ab) plus ->
+  ('ab, 'c, 'm) plus ->
+  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = <fun>
+|}];;
 
 (* 3.9 Computing Programs and Properties Simultaneously *)
 
@@ -176,6 +262,9 @@ let rec plus_assoc : type a b c ab bc m n.
 
 let smaller : type a b. (a succ, b succ) le -> (a,b) le =
   function LeS x -> x ;;
+[%%expect{|
+val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun>
+|}];;
 
 type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;;
 
@@ -197,6 +286,10 @@ let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
   | LeS q, NS x, NS y ->
       match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
 ;;
+[%%expect{|
+type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
+|}];;
 
 let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
   fun le a b ->
@@ -206,6 +299,9 @@ let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
       (match diff q x y with Diff (m, p) -> Diff (m, PlusS p))
   | _ -> .
 ;;
+[%%expect{|
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
+|}];;
 
 let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
   fun le b ->
@@ -214,6 +310,9 @@ let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
   | NS y, LeS q ->
       match diff q y with Diff (m, p) -> Diff (m, PlusS p)
 ;;
+[%%expect{|
+val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = <fun>
+|}];;
 
 type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter
 
@@ -221,6 +320,10 @@ let rec leS' : type m n. (m,n) le -> (m,n succ) le = function
   | LeZ n -> LeZ (NS n)
   | LeS le -> LeS (leS' le)
 ;;
+[%%expect{|
+type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
+val leS' : ('m, 'n) le -> ('m, 'n succ) le = <fun>
+|}];;
 
 let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
   fun f s ->
@@ -231,6 +334,9 @@ let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
         if f a then Filter (LeS le, Scons (a, l'))
         else Filter (leS' le, l')
 ;;
+[%%expect{|
+val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = <fun>
+|}];;
 
 (* 4.1 AVL trees *)
 
@@ -247,7 +353,19 @@ type _ avl =
 type avl' = Avl : 'h avl -> avl'
 ;;
 
-let empty = Avl Leaf
+let empty = Avl Leaf;;
+[%%expect{|
+type (_, _, _) balance =
+    Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+type _ avl =
+    Leaf : zero avl
+  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
+      'hR avl -> 'hMax succ avl
+type avl' = Avl : 'h avl -> avl'
+val empty : avl' = Avl Leaf
+|}];;
 
 let rec elem : type h. int -> h avl -> bool = fun x t ->
   match t with
@@ -255,6 +373,9 @@ let rec elem : type h. int -> h avl -> bool = fun x t ->
   | Node (_, l, y, r) ->
       x = y || if x < y then elem x l else elem x r
 ;;
+[%%expect{|
+val elem : int -> 'h avl -> bool = <fun>
+|}];;
 
 let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
   ((n succ succ) avl, (n succ succ succ) avl) sum =
@@ -269,6 +390,11 @@ let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
   | Node (Less, a, x, Node (More, b, z, c)) ->
       Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
 ;;
+[%%expect{|
+val rotr :
+  'n succ succ avl ->
+  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun>
+|}];;
 let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
   ((n succ succ) avl, (n succ succ succ) avl) sum =
   fun tL u tR ->
@@ -282,6 +408,12 @@ let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
   | Node (More, Node (More, a, x, b), y, c) ->
       Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c)))
 ;;
+[%%expect{|
+val rotl :
+  'n avl ->
+  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
+  <fun>
+|}];;
 let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
   fun x t ->
   match t with
@@ -306,12 +438,18 @@ let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
             | Less -> rotl a y b
       end
 ;;
+[%%expect{|
+val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = <fun>
+|}];;
 
 let insert x (Avl t) =
   match ins x t with
   | Inl t -> Avl t
   | Inr t -> Avl t
 ;;
+[%%expect{|
+val insert : int -> avl' -> avl' = <fun>
+|}];;
 
 let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
   function
@@ -325,6 +463,10 @@ let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
           | Same -> Inr (Node (Less, l, x, r))
           | More -> Inl (Node (Same, l, x, r))
           | Less -> rotl l x r)
+;;
+[%%expect{|
+val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = <fun>
+|}];;
 
 type _ avl_del =
   | Dsame : 'n avl -> 'n avl_del
@@ -377,12 +519,21 @@ let rec del : type n. int -> n avl -> n avl_del = fun y t ->
             end
       end
 ;;
+[%%expect{|
+type _ avl_del =
+    Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+val del : int -> 'n avl -> 'n avl_del = <fun>
+|}];;
 
 let delete x (Avl t) =
   match del x t with
   | Dsame t -> Avl t
   | Ddecr (_, t) -> Avl t
 ;;
+[%%expect{|
+val delete : int -> avl' -> avl' = <fun>
+|}];;
 
 
 (* Exercise 22: Red-black trees *)
@@ -409,6 +560,26 @@ type (_,_) ctxt =
 
 let blacken = function
     Rnode (l, e, r) -> Bnode (l, e, r)
+;;
+[%%expect{|
+type red = RED
+type black = BLACK
+type (_, _) sub_tree =
+    Bleaf : (black, zero) sub_tree
+  | Rnode : (black, 'n) sub_tree * int *
+      (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode : ('cL, 'n) sub_tree * int *
+      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+type dir = LeftD | RightD
+type (_, _) ctxt =
+    CNil : (black, 'n) ctxt
+  | CRed : int * dir * (black, 'n) sub_tree *
+      (red, 'n) ctxt -> (black, 'n) ctxt
+  | CBlk : int * dir * ('c1, 'n) sub_tree *
+      (black, 'n succ) ctxt -> ('c, 'n) ctxt
+val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun>
+|}];;
 
 type _ crep =
   | Red : red crep
@@ -419,6 +590,10 @@ let color : type c n. (c,n) sub_tree -> c crep = function
   | Rnode _ -> Red
   | Bnode _ -> Black
 ;;
+[%%expect{|
+type _ crep = Red : red crep | Black : black crep
+val color : ('c, 'n) sub_tree -> 'c crep = <fun>
+|}];;
 
 let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
   fun ct t ->
@@ -429,6 +604,9 @@ let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
   | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t))
   | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle))
 ;;
+[%%expect{|
+val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = <fun>
+|}];;
 let recolor d1 pE sib d2 gE uncle t =
   match d1, d2 with
   | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle)
@@ -436,6 +614,16 @@ let recolor d1 pE sib d2 gE uncle t =
   | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t))
   | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib))
 ;;
+[%%expect{|
+val recolor :
+  dir ->
+  int ->
+  ('a, 'b) sub_tree ->
+  dir ->
+  int ->
+  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
+  <fun>
+|}];;
 let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
   match d1, d2 with
   | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle))
@@ -443,6 +631,16 @@ let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
   | LeftD,  LeftD  -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y))
   | RightD, LeftD  -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib))
 ;;
+[%%expect{|
+val rotate :
+  dir ->
+  int ->
+  (black, 'a) sub_tree ->
+  dir ->
+  int ->
+  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
+  <fun>
+|}];;
 let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
   fun t ct ->
   match ct with
@@ -454,6 +652,9 @@ let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
       | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct
       | Black -> fill ct (rotate dir e sib dir' e' uncle t)
 ;;
+[%%expect{|
+val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
+|}];;
 let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
   fun e t ct ->
   match t with
@@ -465,8 +666,14 @@ let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
                 else ins e r (CBlk (e', LeftD, l, ct))
   | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct
 ;;
+[%%expect{|
+val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
+|}];;
 let insert e (Root t) = ins e t CNil
 ;;
+[%%expect{|
+val insert : int -> rb_tree -> rb_tree = <fun>
+|}];;
 
 (* 5.7 typed object languages using GADTs *)
 
@@ -479,6 +686,18 @@ type _ term =
 
 let ex1 = Ap (Add, Pair (Const 3, Const 5))
 let ex2 = Pair (ex1, Const 1)
+;;
+[%%expect{|
+type _ term =
+    Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
+val ex2 : (int * int) term =
+  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
+|}];;
 
 let rec eval_term : type a. a term -> a = function
   | Const x -> x
@@ -486,6 +705,10 @@ let rec eval_term : type a. a term -> a = function
   | LT  -> fun (x,y) -> x<y
   | Ap(f,x) -> eval_term f (eval_term x)
   | Pair(x,y) -> (eval_term x, eval_term y)
+;;
+[%%expect{|
+val eval_term : 'a term -> 'a = <fun>
+|}];;
 
 type _ rep =
   | Rint  : int rep
@@ -516,6 +739,15 @@ let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option =
       end
   | _ -> None
 ;;
+[%%expect{|
+type _ rep =
+    Rint : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
+type (_, _) equal = Eq : ('a, 'a) equal
+val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = <fun>
+|}];;
 
 type assoc = Assoc : string * 'a rep * 'a -> assoc
 
@@ -528,6 +760,11 @@ let rec assoc : type a. string -> a rep -> assoc list -> a =
         | None -> failwith ("Wrong type for " ^ x)
         | Some Eq -> v
       else assoc x r env
+;;
+[%%expect{|
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+val assoc : string -> 'a rep -> assoc list -> 'a = <fun>
+|}];;
 
 type _ term =
   | Var   : string * 'a rep -> 'a term
@@ -548,12 +785,31 @@ let rec eval_term : type a. assoc list -> a term -> a =
   | Ap(f,x) -> eval_term env f (eval_term env x)
   | Pair(x,y) -> (eval_term env x, eval_term env y)
 ;;
+[%%expect{|
+type _ term =
+    Var : string * 'a rep -> 'a term
+  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val eval_term : assoc list -> 'a term -> 'a = <fun>
+|}];;
 
 let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint))))
 let ex4 = Ap (ex3, Const 3)
 
 let v4 = eval_term [] ex4
 ;;
+[%%expect{|
+val ex3 : (int -> int) term =
+  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
+val ex4 : int term =
+  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
+   Const 3)
+val v4 : int = 6
+|}];;
 
 (* 5.9/5.10 Language with binding *)
 
@@ -577,6 +833,25 @@ type y = Y
 let ex1 = App (Var X, Shift (Var Y))
 let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y)))
 ;;
+[%%expect{|
+type rnil = RNIL
+type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
+type _ is_row =
+    Rnil : rnil is_row
+  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
+type (_, _) lam =
+    Const : int -> ('e, int) lam
+  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
+  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
+  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+type x = X
+type y = Y
+val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
+  App (Var X, Shift (Var Y))
+val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
+  Abs (<poly>, Abs (<poly>, App (Shift (Var <poly>), Var <poly>)))
+|}];;
 
 type _ env =
   | Enil : rnil env
@@ -591,6 +866,12 @@ let rec eval_lam : type e t. e env -> (e, t) lam -> t =
   | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body
   | _, App (f, x)    -> eval_lam env f (eval_lam env x)
 ;;
+[%%expect{|
+type _ env =
+    Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+val eval_lam : 'e env -> ('e, 't) lam -> 't = <fun>
+|}];;
 
 type add = Add
 type suc = Suc
@@ -607,9 +888,49 @@ let add = Shift (Shift (Var Add : (_, int -> int -> int) lam))
 let double = Abs (X, App (App (Shift add, Var X), Var X))
 let ex3 = App (double, _3)
 ;;
+[%%expect{|
+type add = Add
+type suc = Suc
+val env0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons env = Econs (Zero, 0, Econs (Suc, <fun>, Econs (Add, <fun>, Enil)))
+val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
+val suc :
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = <fun>
+val _1 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc), Var Zero)
+val _2 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
+val _3 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+  App (Shift (Var Suc),
+   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
+val add :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int -> int)
+  lam = Shift (Shift (Var Add))
+val double :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int)
+  lam =
+  Abs (<poly>,
+   App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>))
+val ex3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App
+   (Abs (<poly>,
+     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+   App (Shift (Var Suc),
+    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
+|}];;
 
 let v3 = eval_lam env0 ex3
 ;;
+[%%expect{|
+val v3 : int = 6
+|}];;
 
 (* 5.13: Constructing typing derivations at runtime *)
 
@@ -634,6 +955,10 @@ let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum =
   | I, Ar _ -> Inl "I <> Ar _"
   | Ar _, I -> Inl "Ar _ <> I"
 ;;
+[%%expect{|
+type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = <fun>
+|}];;
 
 type term =
   | C of int
@@ -660,6 +985,18 @@ let rec lookup : type e. string -> e ctx -> e checked =
       | Cerror m -> Cerror m
       | Cok (v, t) -> Cok (Shift v, t)
 ;;
+[%%expect{|
+type term =
+    C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+type _ ctx =
+    Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
+type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
+val lookup : string -> 'e ctx -> 'e checked = <fun>
+|}];;
 
 let rec tc : type n e. n nat -> e ctx -> term -> e checked =
   fun n ctx t ->
@@ -686,6 +1023,9 @@ let rec tc : type n e. n nat -> e ctx -> term -> e checked =
       end
   | C m -> Cok (Const m, I)
 ;;
+[%%expect{|
+val tc : 'n nat -> 'e ctx -> term -> 'e checked = <fun>
+|}];;
 
 let ctx0 =
   Ccons (Zero, "0", I,
@@ -696,14 +1036,45 @@ let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));;
 let c1 = tc NZ ctx0 ex1;;
 let ex2 = Ap (ex1, C 3);;
 let c2 = tc NZ ctx0 ex2;;
+[%%expect{|
+val ctx0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons ctx =
+  Ccons (Zero, "0", I,
+   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
+val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
+val c1 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (Abs (<poly>,
+     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+   Ar (I, I))
+val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
+val c2 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (App
+     (Abs (<poly>,
+       App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+     Const 3),
+   I)
+|}];;
 
 let eval_checked env = function
   | Cerror s -> failwith s
   | Cok (e, I) -> (eval_lam env e : int)
   | Cok _ -> failwith "Can only evaluate expressions of type I"
 ;;
+[%%expect{|
+val eval_checked : 'a env -> 'a checked -> int = <fun>
+|}];;
 
 let v2 = eval_checked env0 c2 ;;
+[%%expect{|
+val v2 : int = 6
+|}];;
 
 (* 5.12 Soundness *)
 
@@ -729,6 +1100,26 @@ type (_,_,_) lam =
 ;;
 
 let ex1 = App (Lam (X, Var X), Const (IntR, 3))
+[%%expect{|
+type pexp = PEXP
+type pval = PVAL
+type _ mode = Pexp : pexp mode | Pval : pval mode
+type ('a, 'b) tarr = TARR
+type tint = TINT
+type (_, _) rel =
+    IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+type (_, _, _) lam =
+    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
+  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
+  | Lam : 'a *
+      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
+  | App : ('m1, 'e, ('s, 't) tarr) lam *
+      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+val ex1 : (pexp, 'a, tint) lam =
+  App (Lam (<poly>, Var <poly>), Const (IntR, <poly>))
+|}];;
 
 let rec mode : type m e t. (m,e,t) lam -> m mode = function
   | Lam (v, body) -> Pval
@@ -737,6 +1128,9 @@ let rec mode : type m e t. (m,e,t) lam -> m mode = function
   | Shift e -> mode e
   | App _ -> Pexp
 ;;
+[%%expect{|
+val mode : ('m, 'e, 't) lam -> 'm mode = <fun>
+|}];;
 
 type (_,_) sub =
   | Id : ('r,'r) sub
@@ -761,6 +1155,15 @@ let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' =
   | Lam(v,x), sub ->
       (match subst x (Push sub) with Ex body -> Ex (Lam (v, body)))
 ;;
+[%%expect{|
+type (_, _) sub =
+    Id : ('r, 'r) sub
+  | Bind : 't * ('m, 'r2, 'x) lam *
+      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
+  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
+type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
+val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = <fun>
+|}];;
 
 type closed = rnil
 
@@ -780,6 +1183,14 @@ let rec rule : type a b.
   | Const (IntTo b, f), Const (IntR, x) ->
       Inr (Const (b, f x))
 ;;
+[%%expect{|
+type closed = rnil
+type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
+val rule :
+  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
+  <fun>
+|}];;
+
 let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
   | Lam (v, body) -> Inr (Lam (v, body))
   | Const (r, v)  -> Inr (Const (r, v))
@@ -797,3 +1208,6 @@ let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
           end
       | Pval, Pval -> rule e1 e2
 ;;
+[%%expect{|
+val onestep : ('m, closed, 't) lam -> 't rlam = <fun>
+|}];;

diff --git a/testsuite/tests/typing-gadts/omega07.ml.principal.reference b/testsuite/tests/typing-gadts/omega07.ml.principal.reference
deleted file mode 100644 (file)
index 6ae426a..0000000
--- a/testsuite/tests/typing-gadts/omega07.ml.principal.reference
+++ /dev/null
@@ -1,304 +0,0 @@
-
-# * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
-type zero = Zero
-type 'a succ = Succ of 'a
-type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
-#             type (_, _) seq =
-    Snil : ('a, zero) seq
-  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
-#   val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
-#       *         type (_, _, _) plus =
-    PlusZ : 'a nat -> (zero, 'a, 'a) plus
-  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
-#         val length : ('a, 'n) seq -> 'n nat = <fun>
-#   *                     type (_, _, _) app =
-    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
-val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
-#                         type tp = TP
-type nd = ND
-type ('a, 'b) fk = FK
-type _ shape =
-    Tp : tp shape
-  | Nd : nd shape
-  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
-#           type tt = TT
-type ff = FF
-type _ boolean = BT : tt boolean | BF : ff boolean
-#                 type (_, _) path =
-    Pnone : 'a -> (tp, 'a) path
-  | Phere : (nd, 'a) path
-  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
-  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
-#         type (_, _) tree =
-    Ttip : (tp, 'a) tree
-  | Tnode : 'a -> (nd, 'a) tree
-  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
-#   val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
-  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
-#                     val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
-  <fun>
-#             val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = <fun>
-#             type (_, _) le =
-    LeZ : 'a nat -> (zero, 'a) le
-  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
-#       type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
-#         type one = zero succ
-type two = one succ
-type three = two succ
-type four = three succ
-#       val even0 : zero even = EvenZ
-val even2 : two even = EvenSS EvenZ
-val even4 : four even = EvenSS (EvenSS EvenZ)
-#   val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
-#         val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = <fun>
-#                                 type (_, _) equal = Eq : ('a, 'a) equal
-val convert : ('a, 'b) equal -> 'a -> 'b = <fun>
-val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun>
-#                                         val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
-  <fun>
-val plus_assoc :
-  ('a, 'b, 'ab) plus ->
-  ('ab, 'c, 'm) plus ->
-  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = <fun>
-#             val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun>
-#   type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
-#   * * * * * * * * *                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
-#                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
-#               val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = <fun>
-#             type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
-val leS' : ('m, 'n) le -> ('m, 'n succ) le = <fun>
-#                   val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = <fun>
-#                             type (_, _, _) balance =
-    Less : ('h, 'h succ, 'h succ) balance
-  | Same : ('h, 'h, 'h) balance
-  | More : ('h succ, 'h, 'h succ) balance
-type _ avl =
-    Leaf : zero avl
-  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
-      'hR avl -> 'hMax succ avl
-type avl' = Avl : 'h avl -> avl'
-#                 val empty : avl' = Avl Leaf
-val elem : int -> 'h avl -> bool = <fun>
-#                           val rotr :
-  'n succ succ avl ->
-  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun>
-#                         val rotl :
-  'n avl ->
-  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
-  <fun>
-#                                               val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = <fun>
-#           val insert : int -> avl' -> avl' = <fun>
-#                                                                                                                                 val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = <fun>
-type _ avl_del =
-    Dsame : 'n avl -> 'n avl_del
-  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
-val del : int -> 'n avl -> 'n avl_del = <fun>
-#           val delete : int -> avl' -> avl' = <fun>
-#                             type red = RED
-type black = BLACK
-type (_, _) sub_tree =
-    Bleaf : (black, zero) sub_tree
-  | Rnode : (black, 'n) sub_tree * int *
-      (black, 'n) sub_tree -> (red, 'n) sub_tree
-  | Bnode : ('cL, 'n) sub_tree * int *
-      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
-type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
-#               type dir = LeftD | RightD
-type (_, _) ctxt =
-    CNil : (black, 'n) ctxt
-  | CRed : int * dir * (black, 'n) sub_tree *
-      (red, 'n) ctxt -> (black, 'n) ctxt
-  | CBlk : int * dir * ('c1, 'n) sub_tree *
-      (black, 'n succ) ctxt -> ('c, 'n) ctxt
-#                         val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun>
-type _ crep = Red : red crep | Black : black crep
-val color : ('c, 'n) sub_tree -> 'c crep = <fun>
-#                   val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = <fun>
-#             val recolor :
-  dir ->
-  int ->
-  ('a, 'b) sub_tree ->
-  dir ->
-  int ->
-  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
-  <fun>
-#             val rotate :
-  dir ->
-  int ->
-  (black, 'a) sub_tree ->
-  dir ->
-  int ->
-  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
-  <fun>
-#                     val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
-#                     val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
-#   val insert : int -> rb_tree -> rb_tree = <fun>
-#                                                                                                 type _ term =
-    Const : int -> int term
-  | Add : (int * int -> int) term
-  | LT : (int * int -> bool) term
-  | Ap : ('a -> 'b) term * 'a term -> 'b term
-  | Pair : 'a term * 'b term -> ('a * 'b) term
-val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
-val ex2 : (int * int) term =
-  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
-val eval_term : 'a term -> 'a = <fun>
-type _ rep =
-    Rint : int rep
-  | Rbool : bool rep
-  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
-  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
-type (_, _) equal = Eq : ('a, 'a) equal
-val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = <fun>
-#                                                               type assoc = Assoc : string * 'a rep * 'a -> assoc
-val assoc : string -> 'a rep -> assoc list -> 'a = <fun>
-type _ term =
-    Var : string * 'a rep -> 'a term
-  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
-  | Const : int -> int term
-  | Add : (int * int -> int) term
-  | LT : (int * int -> bool) term
-  | Ap : ('a -> 'b) term * 'a term -> 'b term
-  | Pair : 'a term * 'b term -> ('a * 'b) term
-val eval_term : assoc list -> 'a term -> 'a = <fun>
-#           val ex3 : (int -> int) term =
-  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
-val ex4 : int term =
-  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
-   Const 3)
-val v4 : int = 6
-#                                             type rnil = RNIL
-type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
-type _ is_row =
-    Rnil : rnil is_row
-  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
-type (_, _) lam =
-    Const : int -> ('e, int) lam
-  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
-  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
-  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
-  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
-type x = X
-type y = Y
-val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
-  App (Var X, Shift (Var Y))
-val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
-  Abs (<poly>, Abs (<poly>, App (Shift (Var <poly>), Var <poly>)))
-#                           type _ env =
-    Enil : rnil env
-  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
-val eval_lam : 'e env -> ('e, 't) lam -> 't = <fun>
-#                               type add = Add
-type suc = Suc
-val env0 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons env = Econs (Zero, 0, Econs (Suc, <fun>, Econs (Add, <fun>, Enil)))
-val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
-val suc :
-  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
-  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = <fun>
-val _1 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam = App (Shift (Var Suc), Var Zero)
-val _2 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
-val _3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam =
-  App (Shift (Var Suc),
-   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
-val add :
-  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
-   int -> int -> int)
-  lam = Shift (Shift (Var Add))
-val double :
-  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
-   int -> int)
-  lam =
-  Abs (<poly>,
-   App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>))
-val ex3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam =
-  App
-   (Abs (<poly>,
-     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
-   App (Shift (Var Suc),
-    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
-#     val v3 : int = 6
-#       *                                       type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
-val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = <fun>
-#                     type term =
-    C of int
-  | Ab : string * 'a rep * term -> term
-  | Ap of term * term
-  | V of string
-type _ ctx =
-    Cnil : rnil ctx
-  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
-#                             type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
-val lookup : string -> 'e ctx -> 'e checked = <fun>
-#                                                   val tc : 'n nat -> 'e ctx -> term -> 'e checked = <fun>
-#             val ctx0 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons ctx =
-  Ccons (Zero, "0", I,
-   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
-val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
-# val c1 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons checked =
-  Cok
-   (Abs (<poly>,
-     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
-   Ar (I, I))
-# val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
-# val c2 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons checked =
-  Cok
-   (App
-     (Abs (<poly>,
-       App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
-     Const 3),
-   I)
-#           val eval_checked : 'a env -> 'a checked -> int = <fun>
-#   val v2 : int = 6
-#                                             type pexp = PEXP
-type pval = PVAL
-type _ mode = Pexp : pexp mode | Pval : pval mode
-type ('a, 'b) tarr = TARR
-type tint = TINT
-type (_, _) rel =
-    IntR : (tint, int) rel
-  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
-type (_, _, _) lam =
-    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
-  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
-  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
-  | Lam : 'a *
-      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
-  | App : ('m1, 'e, ('s, 't) tarr) lam *
-      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
-#                   val ex1 : (pexp, 'a, tint) lam =
-  App (Lam (<poly>, Var <poly>), Const (IntR, <poly>))
-val mode : ('m, 'e, 't) lam -> 'm mode = <fun>
-#               type (_, _) sub =
-    Id : ('r, 'r) sub
-  | Bind : 't * ('m, 'r2, 'x) lam *
-      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
-  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
-type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
-#                               val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = <fun>
-#       type closed = rnil
-type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
-#                             val rule :
-  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
-  <fun>
-#                                 val onestep : ('m, closed, 't) lam -> 't rlam = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/omega07.ml.reference b/testsuite/tests/typing-gadts/omega07.ml.reference
deleted file mode 100644 (file)
index 6ae426a..0000000
--- a/testsuite/tests/typing-gadts/omega07.ml.reference
+++ /dev/null
@@ -1,304 +0,0 @@
-
-# * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
-type zero = Zero
-type 'a succ = Succ of 'a
-type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
-#             type (_, _) seq =
-    Snil : ('a, zero) seq
-  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
-#   val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
-#       *         type (_, _, _) plus =
-    PlusZ : 'a nat -> (zero, 'a, 'a) plus
-  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
-#         val length : ('a, 'n) seq -> 'n nat = <fun>
-#   *                     type (_, _, _) app =
-    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
-val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
-#                         type tp = TP
-type nd = ND
-type ('a, 'b) fk = FK
-type _ shape =
-    Tp : tp shape
-  | Nd : nd shape
-  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
-#           type tt = TT
-type ff = FF
-type _ boolean = BT : tt boolean | BF : ff boolean
-#                 type (_, _) path =
-    Pnone : 'a -> (tp, 'a) path
-  | Phere : (nd, 'a) path
-  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
-  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
-#         type (_, _) tree =
-    Ttip : (tp, 'a) tree
-  | Tnode : 'a -> (nd, 'a) tree
-  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
-#   val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
-  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
-#                     val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
-  <fun>
-#             val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = <fun>
-#             type (_, _) le =
-    LeZ : 'a nat -> (zero, 'a) le
-  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
-#       type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
-#         type one = zero succ
-type two = one succ
-type three = two succ
-type four = three succ
-#       val even0 : zero even = EvenZ
-val even2 : two even = EvenSS EvenZ
-val even4 : four even = EvenSS (EvenSS EvenZ)
-#   val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
-#         val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = <fun>
-#                                 type (_, _) equal = Eq : ('a, 'a) equal
-val convert : ('a, 'b) equal -> 'a -> 'b = <fun>
-val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun>
-#                                         val plus_func : ('a, 'b, 'm) plus -> ('a, 'b, 'n) plus -> ('m, 'n) equal =
-  <fun>
-val plus_assoc :
-  ('a, 'b, 'ab) plus ->
-  ('ab, 'c, 'm) plus ->
-  ('b, 'c, 'bc) plus -> ('a, 'bc, 'n) plus -> ('m, 'n) equal = <fun>
-#             val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun>
-#   type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
-#   * * * * * * * * *                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
-#                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
-#               val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = <fun>
-#             type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
-val leS' : ('m, 'n) le -> ('m, 'n succ) le = <fun>
-#                   val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = <fun>
-#                             type (_, _, _) balance =
-    Less : ('h, 'h succ, 'h succ) balance
-  | Same : ('h, 'h, 'h) balance
-  | More : ('h succ, 'h, 'h succ) balance
-type _ avl =
-    Leaf : zero avl
-  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
-      'hR avl -> 'hMax succ avl
-type avl' = Avl : 'h avl -> avl'
-#                 val empty : avl' = Avl Leaf
-val elem : int -> 'h avl -> bool = <fun>
-#                           val rotr :
-  'n succ succ avl ->
-  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun>
-#                         val rotl :
-  'n avl ->
-  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
-  <fun>
-#                                               val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = <fun>
-#           val insert : int -> avl' -> avl' = <fun>
-#                                                                                                                                 val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = <fun>
-type _ avl_del =
-    Dsame : 'n avl -> 'n avl_del
-  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
-val del : int -> 'n avl -> 'n avl_del = <fun>
-#           val delete : int -> avl' -> avl' = <fun>
-#                             type red = RED
-type black = BLACK
-type (_, _) sub_tree =
-    Bleaf : (black, zero) sub_tree
-  | Rnode : (black, 'n) sub_tree * int *
-      (black, 'n) sub_tree -> (red, 'n) sub_tree
-  | Bnode : ('cL, 'n) sub_tree * int *
-      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
-type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
-#               type dir = LeftD | RightD
-type (_, _) ctxt =
-    CNil : (black, 'n) ctxt
-  | CRed : int * dir * (black, 'n) sub_tree *
-      (red, 'n) ctxt -> (black, 'n) ctxt
-  | CBlk : int * dir * ('c1, 'n) sub_tree *
-      (black, 'n succ) ctxt -> ('c, 'n) ctxt
-#                         val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun>
-type _ crep = Red : red crep | Black : black crep
-val color : ('c, 'n) sub_tree -> 'c crep = <fun>
-#                   val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = <fun>
-#             val recolor :
-  dir ->
-  int ->
-  ('a, 'b) sub_tree ->
-  dir ->
-  int ->
-  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
-  <fun>
-#             val rotate :
-  dir ->
-  int ->
-  (black, 'a) sub_tree ->
-  dir ->
-  int ->
-  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
-  <fun>
-#                     val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
-#                     val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
-#   val insert : int -> rb_tree -> rb_tree = <fun>
-#                                                                                                 type _ term =
-    Const : int -> int term
-  | Add : (int * int -> int) term
-  | LT : (int * int -> bool) term
-  | Ap : ('a -> 'b) term * 'a term -> 'b term
-  | Pair : 'a term * 'b term -> ('a * 'b) term
-val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
-val ex2 : (int * int) term =
-  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
-val eval_term : 'a term -> 'a = <fun>
-type _ rep =
-    Rint : int rep
-  | Rbool : bool rep
-  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
-  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
-type (_, _) equal = Eq : ('a, 'a) equal
-val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = <fun>
-#                                                               type assoc = Assoc : string * 'a rep * 'a -> assoc
-val assoc : string -> 'a rep -> assoc list -> 'a = <fun>
-type _ term =
-    Var : string * 'a rep -> 'a term
-  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
-  | Const : int -> int term
-  | Add : (int * int -> int) term
-  | LT : (int * int -> bool) term
-  | Ap : ('a -> 'b) term * 'a term -> 'b term
-  | Pair : 'a term * 'b term -> ('a * 'b) term
-val eval_term : assoc list -> 'a term -> 'a = <fun>
-#           val ex3 : (int -> int) term =
-  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
-val ex4 : int term =
-  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
-   Const 3)
-val v4 : int = 6
-#                                             type rnil = RNIL
-type ('a, 'b, 'c) rcons = RCons of 'a * 'b * 'c
-type _ is_row =
-    Rnil : rnil is_row
-  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
-type (_, _) lam =
-    Const : int -> ('e, int) lam
-  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
-  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
-  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
-  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
-type x = X
-type y = Y
-val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
-  App (Var X, Shift (Var Y))
-val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
-  Abs (<poly>, Abs (<poly>, App (Shift (Var <poly>), Var <poly>)))
-#                           type _ env =
-    Enil : rnil env
-  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
-val eval_lam : 'e env -> ('e, 't) lam -> 't = <fun>
-#                               type add = Add
-type suc = Suc
-val env0 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons env = Econs (Zero, 0, Econs (Suc, <fun>, Econs (Add, <fun>, Enil)))
-val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
-val suc :
-  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
-  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = <fun>
-val _1 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam = App (Shift (Var Suc), Var Zero)
-val _2 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
-val _3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam =
-  App (Shift (Var Suc),
-   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
-val add :
-  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
-   int -> int -> int)
-  lam = Shift (Shift (Var Add))
-val double :
-  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
-   int -> int)
-  lam =
-  Abs (<poly>,
-   App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>))
-val ex3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
-   rcons, int)
-  lam =
-  App
-   (Abs (<poly>,
-     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
-   App (Shift (Var Suc),
-    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
-#     val v3 : int = 6
-#       *                                       type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
-val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = <fun>
-#                     type term =
-    C of int
-  | Ab : string * 'a rep * term -> term
-  | Ap of term * term
-  | V of string
-type _ ctx =
-    Cnil : rnil ctx
-  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
-#                             type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
-val lookup : string -> 'e ctx -> 'e checked = <fun>
-#                                                   val tc : 'n nat -> 'e ctx -> term -> 'e checked = <fun>
-#             val ctx0 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons ctx =
-  Ccons (Zero, "0", I,
-   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
-val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
-# val c1 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons checked =
-  Cok
-   (Abs (<poly>,
-     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
-   Ar (I, I))
-# val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
-# val c2 :
-  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
-  rcons checked =
-  Cok
-   (App
-     (Abs (<poly>,
-       App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
-     Const 3),
-   I)
-#           val eval_checked : 'a env -> 'a checked -> int = <fun>
-#   val v2 : int = 6
-#                                             type pexp = PEXP
-type pval = PVAL
-type _ mode = Pexp : pexp mode | Pval : pval mode
-type ('a, 'b) tarr = TARR
-type tint = TINT
-type (_, _) rel =
-    IntR : (tint, int) rel
-  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
-type (_, _, _) lam =
-    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
-  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
-  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
-  | Lam : 'a *
-      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
-  | App : ('m1, 'e, ('s, 't) tarr) lam *
-      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
-#                   val ex1 : (pexp, 'a, tint) lam =
-  App (Lam (<poly>, Var <poly>), Const (IntR, <poly>))
-val mode : ('m, 'e, 't) lam -> 'm mode = <fun>
-#               type (_, _) sub =
-    Id : ('r, 'r) sub
-  | Bind : 't * ('m, 'r2, 'x) lam *
-      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
-  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
-type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
-#                               val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = <fun>
-#       type closed = rnil
-type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
-#                             val rule :
-  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
-  <fun>
-#                                 val onestep : ('m, closed, 't) lam -> 't rlam = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/pr5332.ml b/testsuite/tests/typing-gadts/pr5332.ml
index 700e37b1c982c96f96b2f40c31ac00eae63f1be2..e0c77acdea68a5fed14c72955373b45da9baa2dd 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5332.ml
+++ b/testsuite/tests/typing-gadts/pr5332.ml
@@ -14,4 +14,16 @@ let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
    | Tvar var, tb -> 2
    | _ -> .   (* error *)
 ;;
+[%%expect{|
+type ('env, 'a) var =
+    Zero : ('a * 'env, 'a) var
+  | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+type ('env, 'a) typ =
+    Tint : ('env, int) typ
+  | Tbool : ('env, bool) typ
+  | Tvar : ('env, 'a) var -> ('env, 'a) typ
+Line _, characters 5-6:
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: (Tint, Tvar Zero)
+|}];;
 (* let x = f Tint (Tvar Zero) ;; *)

diff --git a/testsuite/tests/typing-gadts/pr5332.ml.reference b/testsuite/tests/typing-gadts/pr5332.ml.reference
deleted file mode 100644 (file)
index 3abbcff..0000000
--- a/testsuite/tests/typing-gadts/pr5332.ml.reference
+++ /dev/null
@@ -1,14 +0,0 @@
-
-#       type ('env, 'a) var =
-    Zero : ('a * 'env, 'a) var
-  | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
-#         type ('env, 'a) typ =
-    Tint : ('env, int) typ
-  | Tbool : ('env, bool) typ
-  | Tvar : ('env, 'a) var -> ('env, 'a) typ
-#             Characters 162-163:
-     | _ -> .   (* error *)
-       ^
-Error: This match case could not be refuted.
-       Here is an example of a value that would reach it: (Tint, Tvar Zero)
-#   

diff --git a/testsuite/tests/typing-gadts/pr5689.ml b/testsuite/tests/typing-gadts/pr5689.ml
index 856ddc2738f9a0b4137df35192e6222a46514fa2..748212d47ed7e3e82a82c660b0d56080565684bc 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5689.ml
+++ b/testsuite/tests/typing-gadts/pr5689.ml
@@ -15,6 +15,16 @@ let uppercase seq =
        | Mref (lnk, xs) -> Mref (lnk, List.map process xs)
    in List.map process seq
 ;;
+[%%expect{|
+type inkind = [ `Link | `Nonlink ]
+type _ inline_t =
+    Text : string -> [< inkind > `Nonlink ] inline_t
+  | Bold : 'a inline_t list -> 'a inline_t
+  | Link : string -> [< inkind > `Link ] inline_t
+  | Mref : string *
+      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+val uppercase : 'a inline_t list -> 'a inline_t list = <fun>
+|}];;
 
 type ast_t =
    | Ast_Text of string
@@ -35,6 +45,14 @@ let inlineseq_from_astseq seq =
        | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs)
    in List.map process_any seq
 ;;
+[%%expect{|
+type ast_t =
+    Ast_Text of string
+  | Ast_Bold of ast_t list
+  | Ast_Link of string
+  | Ast_Mref of string * ast_t list
+val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
+|}];;
 
 (* OK *)
 type _ linkp =
@@ -55,6 +73,10 @@ let inlineseq_from_astseq seq =
      | (Nonlink, Ast_Mref _)      -> assert false
    in List.map (process Maylink) seq
 ;;
+[%%expect{|
+type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
+val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
+|}];;
 
 (* Bad *)
 type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
@@ -72,3 +94,12 @@ let rec process : type a. a linkp2 -> ast_t -> a inline_t =
     | (Kind Nonlink, Ast_Mref _)      -> assert false
   in List.map (process (Kind Maylink)) seq
 ;;
+[%%expect{|
+type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+Line _, characters 35-43:
+Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
+       but an expression was expected of type a inline_t
+       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
+         a = [< `Link | `Nonlink ]
+       Types for tag `Nonlink are incompatible
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5689.ml.principal.reference b/testsuite/tests/typing-gadts/pr5689.ml.principal.reference
deleted file mode 100644 (file)
index fabdb17..0000000
--- a/testsuite/tests/typing-gadts/pr5689.ml.principal.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-
-#               type inkind = [ `Link | `Nonlink ]
-type _ inline_t =
-    Text : string -> [< inkind > `Nonlink ] inline_t
-  | Bold : 'a inline_t list -> 'a inline_t
-  | Link : string -> [< inkind > `Link ] inline_t
-  | Mref : string *
-      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
-#                 val uppercase : 'a inline_t list -> 'a inline_t list = <fun>
-#             type ast_t =
-    Ast_Text of string
-  | Ast_Bold of ast_t list
-  | Ast_Link of string
-  | Ast_Mref of string * ast_t list
-#                         val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
-#           type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
-#                           val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
-#       type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
-#                         Characters 184-192:
-      | (Kind _, Ast_Text txt)    -> Text txt
-                                     ^^^^^^^^
-Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
-       but an expression was expected of type a inline_t
-       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
-         a = [< `Link | `Nonlink ] 
-       Types for tag `Nonlink are incompatible
-# 

diff --git a/testsuite/tests/typing-gadts/pr5689.ml.reference b/testsuite/tests/typing-gadts/pr5689.ml.reference
deleted file mode 100644 (file)
index fabdb17..0000000
--- a/testsuite/tests/typing-gadts/pr5689.ml.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-
-#               type inkind = [ `Link | `Nonlink ]
-type _ inline_t =
-    Text : string -> [< inkind > `Nonlink ] inline_t
-  | Bold : 'a inline_t list -> 'a inline_t
-  | Link : string -> [< inkind > `Link ] inline_t
-  | Mref : string *
-      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
-#                 val uppercase : 'a inline_t list -> 'a inline_t list = <fun>
-#             type ast_t =
-    Ast_Text of string
-  | Ast_Bold of ast_t list
-  | Ast_Link of string
-  | Ast_Mref of string * ast_t list
-#                         val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
-#           type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
-#                           val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
-#       type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
-#                         Characters 184-192:
-      | (Kind _, Ast_Text txt)    -> Text txt
-                                     ^^^^^^^^
-Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
-       but an expression was expected of type a inline_t
-       Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
-         a = [< `Link | `Nonlink ] 
-       Types for tag `Nonlink are incompatible
-# 

diff --git a/testsuite/tests/typing-gadts/pr5785.ml b/testsuite/tests/typing-gadts/pr5785.ml
index fdfa7ebfc8ecf0a8ecc6151f5dee1191deeb00dd..9624adcdcbdb4b43c67075d60c440b9039ed0166 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5785.ml
+++ b/testsuite/tests/typing-gadts/pr5785.ml
@@ -8,3 +8,15 @@ struct
     | One, One -> "two"
     | Two, Two -> "four"
 end;;
+[%%expect{|
+Line _, characters 43-100:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Two, One)
+module Add :
+  functor (T : sig type two end) ->
+    sig
+      type _ t = One : [ `One ] t | Two : T.two t
+      val add : 'a t * 'a t -> string
+    end
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5785.ml.reference b/testsuite/tests/typing-gadts/pr5785.ml.reference
deleted file mode 100644 (file)
index 0a1fb77..0000000
--- a/testsuite/tests/typing-gadts/pr5785.ml.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#                   Characters 137-194:
-  ...........................................function
-      | One, One -> "two"
-      | Two, Two -> "four"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(Two, One)
-module Add :
-  functor (T : sig type two end) ->
-    sig
-      type _ t = One : [ `One ] t | Two : T.two t
-      val add : 'a t * 'a t -> string
-    end
-# 

diff --git a/testsuite/tests/typing-gadts/pr5848.ml b/testsuite/tests/typing-gadts/pr5848.ml
index c07e30c9a0dbf6a121d76d3b8453faaf644aeead..d1ebbdf5874fac12c237c6efca24fe8197b526d6 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5848.ml
+++ b/testsuite/tests/typing-gadts/pr5848.ml
@@ -12,3 +12,9 @@ let of_type: type a. a -> a = fun x ->
   match B.f x 4 with
   | Eq -> 5
 ;;
+[%%expect{|
+module B :
+  sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end
+Line _, characters 4-6:
+Error: The GADT constructor Eq of type B.t must be qualified in this pattern.
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5848.ml.reference b/testsuite/tests/typing-gadts/pr5848.ml.reference
deleted file mode 100644 (file)
index 577a6dc..0000000
--- a/testsuite/tests/typing-gadts/pr5848.ml.reference
+++ /dev/null
@@ -1,8 +0,0 @@
-
-#                 module B :
-  sig type (_, _) t = Eq : ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end
-#         Characters 65-67:
-    | Eq -> 5
-      ^^
-Error: The GADT constructor Eq of type B.t must be qualified in this pattern.
-# 

diff --git a/testsuite/tests/typing-gadts/pr5906.ml b/testsuite/tests/typing-gadts/pr5906.ml
index f0b2f0b07da1d5b4b2cf793195fe9a4416b2c1ce..a9541265b05d59b11ff03f61a3877cb7a1248a3b 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5906.ml
+++ b/testsuite/tests/typing-gadts/pr5906.ml
@@ -16,3 +16,18 @@ let eval (type a) (type b) (type c) (bop:(a,b,c) binop) (x:a constant)
   | Add, Int x, Int y -> Int (x + y)
 
 let _ = eval Eq (Int 2) (Int 3)
+
+[%%expect{|
+type _ constant = Int : int -> int constant | Bool : bool -> bool constant
+type (_, _, _) binop =
+    Eq : ('a, 'a, bool) binop
+  | Leq : ('a, 'a, bool) binop
+  | Add : (int, int, int) binop
+Line _, characters 2-195:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Eq, Int _, _)
+val eval : ('a, 'b, 'c) binop -> 'a constant -> 'b constant -> 'c constant =
+  <fun>
+Exception: Match_failure ("", 12, 2).
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5906.ml.reference b/testsuite/tests/typing-gadts/pr5906.ml.reference
deleted file mode 100644 (file)
index 28a103c..0000000
--- a/testsuite/tests/typing-gadts/pr5906.ml.reference
+++ /dev/null
@@ -1,5 +0,0 @@
-
-#                                     
-Characters 533-533:
-  Error: Syntax error
-# 

diff --git a/testsuite/tests/typing-gadts/pr5948.ml b/testsuite/tests/typing-gadts/pr5948.ml
index 0acc90868b6c67c5e6c63650e691be6289caac7c..52477628a61322923aaa95c5d2807d31ae60bd4f 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5948.ml
+++ b/testsuite/tests/typing-gadts/pr5948.ml
@@ -25,6 +25,27 @@ let example6 : type a. a wrapPoly -> (a -> int) =
     | WrapPoly ATag -> intA
     | WrapPoly _ -> intA (* This should not be allowed *)
 ;;
+[%%expect{|
+type tag = [ `TagA | `TagB | `TagC ]
+type 'a poly =
+    AandBTags : [< `TagA of int | `TagB ] poly
+  | ATag : [< `TagA of int ] poly
+val intA : [< `TagA of 'a ] -> 'a = <fun>
+val intB : [< `TagB ] -> int = <fun>
+val intAorB : [< `TagA of int | `TagB ] -> int = <fun>
+type _ wrapPoly =
+    WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly
+Line _, characters 23-27:
+Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b
+       but an expression was expected of type a -> int
+       Type [< `TagA of 'b ] as 'a is not compatible with type
+         a = [< `TagA of int | `TagB ]
+       The first variant type does not allow tag(s) `TagB
+|}];;
 
 let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
 ;;
+[%%expect{|
+Line _, characters 9-17:
+Error: Unbound value example6
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5948.ml.reference b/testsuite/tests/typing-gadts/pr5948.ml.reference
deleted file mode 100644 (file)
index 597cbfa..0000000
--- a/testsuite/tests/typing-gadts/pr5948.ml.reference
+++ /dev/null
@@ -1,23 +0,0 @@
-
-# type tag = [ `TagA | `TagB | `TagC ]
-#           type 'a poly =
-    AandBTags : [< `TagA of int | `TagB ] poly
-  | ATag : [< `TagA of int ] poly
-#       val intA : [< `TagA of 'a ] -> 'a = <fun>
-val intB : [< `TagB ] -> int = <fun>
-#         val intAorB : [< `TagA of int | `TagB ] -> int = <fun>
-#       type _ wrapPoly =
-    WrapPoly : 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly
-#             Characters 103-107:
-      | WrapPoly ATag -> intA
-                         ^^^^
-Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b
-       but an expression was expected of type a -> int
-       Type [< `TagA of 'b ] as 'a is not compatible with type
-         a = [< `TagA of int | `TagB ] 
-       The first variant type does not allow tag(s) `TagB
-#     Characters 10-18:
-  let _ =  example6 (WrapPoly AandBTags) `TagB (* This causes a seg fault *)
-           ^^^^^^^^
-Error: Unbound value example6
-# 

diff --git a/testsuite/tests/typing-gadts/pr5981.ml b/testsuite/tests/typing-gadts/pr5981.ml
index f93b4e36f57e49713a08a17a7584d27a6e8182e7..bda9a883f836d6c95943cd6661c6212e777f5089 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5981.ml
+++ b/testsuite/tests/typing-gadts/pr5981.ml
@@ -7,6 +7,18 @@ module F(S : sig type 'a t end) = struct
     fun (l : int S.t ab) (r : float S.t ab) -> match l, r with
     | A, B -> "f A B"
 end;;
+[%%expect{|
+Line _, characters 47-84:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A, A)
+module F :
+  functor (S : sig type 'a t end) ->
+    sig
+      type _ ab = A : int S.t ab | B : float S.t ab
+      val f : int S.t ab -> float S.t ab -> string
+    end
+|}];;
 
 module F(S : sig type 'a t end) = struct
   type a = int * int
@@ -20,3 +32,17 @@ module F(S : sig type 'a t end) = struct
     fun l r -> match l, r with
     | A, B -> "f A B"
 end;;
+[%%expect{|
+Line _, characters 15-52:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(A, A)
+module F :
+  functor (S : sig type 'a t end) ->
+    sig
+      type a = int * int
+      type b = int -> int
+      type _ ab = A : a S.t ab | B : b S.t ab
+      val f : a S.t ab -> b S.t ab -> string
+    end
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5981.ml.reference b/testsuite/tests/typing-gadts/pr5981.ml.reference
deleted file mode 100644 (file)
index 3a2d7b1..0000000
--- a/testsuite/tests/typing-gadts/pr5981.ml.reference
+++ /dev/null
@@ -1,28 +0,0 @@
-
-#                 Characters 196-233:
-  ...............................................match l, r with
-      | A, B -> "f A B"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(A, A)
-module F :
-  functor (S : sig type 'a t end) ->
-    sig
-      type _ ab = A : int S.t ab | B : float S.t ab
-      val f : int S.t ab -> float S.t ab -> string
-    end
-#                         Characters 197-234:
-  ...............match l, r with
-      | A, B -> "f A B"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(A, A)
-module F :
-  functor (S : sig type 'a t end) ->
-    sig
-      type a = int * int
-      type b = int -> int
-      type _ ab = A : a S.t ab | B : b S.t ab
-      val f : a S.t ab -> b S.t ab -> string
-    end
-# 

diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml
index 23902add3758025c9cc25eacd8193b410976ecc4..0243887f0aed0b0ef411718717c3b3b574a1f918 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5985.ml
+++ b/testsuite/tests/typing-gadts/pr5985.ml
@@ -3,17 +3,22 @@ module F (S : sig type 'a s end) = struct
   include S
   type _ t = T : 'a -> 'a s t
 end;; (* fail *)
+[%%expect{|
+Line _, characters 2-29:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 (*
 module M = F (struct type 'a s = int end) ;;
 let M.T x = M.T 3 in x = true;;
 *)
 
 (* Fix it using #-annotations *)
+(*
 module F (S : sig type #'a s end) = struct
   include S
   type _ t = T : 'a -> 'a s t
 end;; (* syntax error *)
-(*
 module M = F (struct type 'a s = int end) ;; (* fail *)
 module M = F (struct type 'a s = new int end) ;; (* ok *)
 let M.T x = M.T 3 in x = true;; (* fail *)
@@ -25,6 +30,11 @@ module F(T:sig type 'a t end) = struct
   class ['a] c x =
     object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
 end;; (* fail *)
+[%%expect{|
+Line _, characters 2-86:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 
 (* Another (more direct) instance using polymorphic variants *)
 (* PR#6275 *)
@@ -32,7 +42,18 @@ type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *)
 let magic (x : int) : bool  =
   let A x = A x in
   x;; (* fail *)
+[%%expect{|
+Line _, characters 0-49:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
+
 type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *)
+[%%expect{|
+Line _, characters 0-37:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 
 (* It is not OK to allow modules exported by other compilation units *)
 type (_,_) eq = Eq : ('a,'a) eq;;
@@ -40,6 +61,14 @@ let eq = Obj.magic Eq;;
 (* pretend that Queue.t is not injective *)
 let eq : ('a Queue.t, 'b Queue.t) eq = eq;;
 type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq
+val eq : 'a = <poly>
+val eq : ('a Queue.t, 'b Queue.t) eq = Eq
+Line _, characters 0-33:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 (*
 let castT (type a) (type b) (x : a t) (e: (a, b) eq) : b t =
   let Eq = e in (x : b t);;
@@ -51,18 +80,27 @@ module type S = sig
   type 'a s
   type _ t = T : 'a -> 'a s t
 end;; (* fail *)
+[%%expect{|
+Line _, characters 2-29:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;
 (* Otherwise we can write the following *)
 module rec M : (S with type 'a s = unit) = M;;
+[%%expect{|
+Line _, characters 16-17:
+Error: Unbound module type S
+|}];;
 (* For the above reason, we cannot allow the abstract declaration
    of s and the definition of t to be in the same module, as
    we could create the signature using [module type of ...] *)
 
 
 (* Another problem with variance *)
+(*
 module M = struct type 'a t = 'a -> unit end;;
 module F(X:sig type #'a t end) =
   struct type +'a s = S of 'b constraint 'a = 'b X.t end;; (* fail *)
-(*
 module N = F(M);;
 let o = N.S (object end);;
 let N.S o' = (o :> <m : int> M.t N.s);; (* unsound! *)
@@ -71,20 +109,51 @@ let N.S o' = (o :> <m : int> M.t N.s);; (* unsound! *)
 (* And yet another *)
 type 'a q = Q;;
 type +'a t = 'b constraint 'a = 'b q;;
+[%%expect{|
+type 'a q = Q
+Line _, characters 0-36:
+Error: In this definition, a type variable has a variance that
+       cannot be deduced from the type parameters.
+       It was expected to be unrestricted, but it is covariant.
+|}];;
 (* shoud fail: we do not know for sure the variance of Queue.t *)
 
 type +'a t = T of 'a;;
 type +'a s = 'b constraint 'a = 'b t;; (* ok *)
+[%%expect{|
+type 'a t = T of 'a
+type +'a s = 'b constraint 'a = 'b t
+|}];;
 type -'a s = 'b constraint 'a = 'b t;; (* fail *)
+[%%expect{|
+Line _, characters 0-36:
+Error: In this definition, a type variable has a variance that
+       is not reflected by its occurrence in type parameters.
+       It was expected to be contravariant, but it is covariant.
+|}];;
 type +'a u = 'a t;;
 type 'a t = T of ('a -> 'a);;
 type -'a s = 'b constraint 'a = 'b t;; (* ok *)
+[%%expect{|
+type 'a u = 'a t
+type 'a t = T of ('a -> 'a)
+type -'a s = 'b constraint 'a = 'b t
+|}];;
 type +'a s = 'b constraint 'a = 'b q t;; (* ok *)
+[%%expect{|
+type +'a s = 'b constraint 'a = 'b q t
+|}];;
 type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
+[%%expect{|
+Line _, characters 0-38:
+Error: In this definition, a type variable has a variance that
+       cannot be deduced from the type parameters.
+       It was expected to be unrestricted, but it is covariant.
+|}];;
 
 
 (* the problem from lablgtk2 *)
-
+(*
 module Gobject = struct
   type -'a obj
 end
@@ -95,8 +164,14 @@ class virtual ['a] item_container =
    constraint 'a = < as_item : [>`widget] obj; .. >
    method virtual add : 'a -> unit
  end;;
-
+*)
 
 (* Another variance anomaly, should not expand t in g before checking *)
 type +'a t = unit constraint 'a = 'b list;;
 type _ g = G : 'a -> 'a t g;; (* fail *)
+[%%expect{|
+type +'a t = unit constraint 'a = 'b list
+Line _, characters 0-27:
+Error: In this definition, a type variable cannot be deduced
+       from the type parameters.
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5985.ml.reference b/testsuite/tests/typing-gadts/pr5985.ml.reference
deleted file mode 100644 (file)
index 4c29f6d..0000000
--- a/testsuite/tests/typing-gadts/pr5985.ml.reference
+++ /dev/null
@@ -1,89 +0,0 @@
-
-#         Characters 88-115:
-    type _ t = T : 'a -> 'a s t
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-# * * *             Characters 140-141:
-  module F (S : sig type #'a s end) = struct
-                         ^
-Error: Syntax error
-# * * * * *             Characters 290-374:
-  ..class ['a] c x =
-      object constraint 'a = 'b T.t val x' : 'b = x method x = x' end
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-#       Characters 79-128:
-  type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-#     Characters 36-37:
-    let A x = A x in
-        ^
-Error: Unbound constructor A
-# Characters 0-37:
-  type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-#     type (_, _) eq = Eq : ('a, 'a) eq
-# val eq : 'a = <poly>
-#   val eq : ('a Queue.t, 'b Queue.t) eq = Eq
-# Characters 0-33:
-  type _ t = T : 'a -> 'a Queue.t t;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-# * * * *             Characters 250-277:
-    type _ t = T : 'a -> 'a s t
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-#   Characters 59-60:
-  module rec M : (S with type 'a s = unit) = M;;
-                  ^
-Error: Unbound module type S
-# * *         module M : sig type 'a t = 'a -> unit end
-#   Characters 20-21:
-  module F(X:sig type #'a t end) =
-                      ^
-Error: Syntax error
-# * * * *       type 'a q = Q
-# Characters 0-36:
-  type +'a t = 'b constraint 'a = 'b q;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable has a variance that
-       cannot be deduced from the type parameters.
-       It was expected to be unrestricted, but it is covariant.
-#     type 'a t = T of 'a
-# type +'a s = 'b constraint 'a = 'b t
-# Characters 0-36:
-  type -'a s = 'b constraint 'a = 'b t;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable has a variance that
-       is not reflected by its occurrence in type parameters.
-       It was expected to be contravariant, but it is covariant.
-# type 'a u = 'a t
-# type 'a t = T of ('a -> 'a)
-# type -'a s = 'b constraint 'a = 'b t
-# type +'a s = 'b constraint 'a = 'b q t
-# Characters 0-38:
-  type +'a s = 'b constraint 'a = 'b t q;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable has a variance that
-       cannot be deduced from the type parameters.
-       It was expected to be unrestricted, but it is covariant.
-#               module Gobject : sig type -'a obj end
-#           class virtual ['a] item_container :
-  object
-    constraint 'a = < as_item : [> `widget ] Gobject.obj; .. >
-    method virtual add : 'a -> unit
-  end
-#       type +'a t = unit constraint 'a = 'b list
-# Characters 0-27:
-  type _ g = G : 'a -> 'a t g;; (* fail *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this definition, a type variable cannot be deduced
-       from the type parameters.
-# 

diff --git a/testsuite/tests/typing-gadts/pr5989.ml b/testsuite/tests/typing-gadts/pr5989.ml
index 392df7f2d6a2f77f8842169808ce0a56ab45a11f..0abf7cb3d666e53f23cc02bbc0d9c5cca744522d 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5989.ml
+++ b/testsuite/tests/typing-gadts/pr5989.ml
@@ -18,6 +18,16 @@ let f : (M.s, [`A | `B]) t -> string = function
 ;;
 
 let () = print_endline (f M.eq) ;;
+[%%expect{|
+type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
+module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
+Line _, characters 39-64:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : (M.s, [ `A | `B ]) t -> string = <fun>
+Exception: Match_failure ("", 16, 39).
+|}];;
 
 module N :
 sig
@@ -33,3 +43,15 @@ end
 let f : (N.s, <a : int; b : bool>) t -> string = function
   | Any -> "Any"
 ;;
+[%%expect{|
+module N :
+  sig
+    type s = private < a : int; .. >
+    val eq : (s, < a : int; b : bool >) t
+  end
+Line _, characters 49-74:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : (N.s, < a : int; b : bool >) t -> string = <fun>
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5989.ml.reference b/testsuite/tests/typing-gadts/pr5989.ml.reference
deleted file mode 100644 (file)
index f881c9b..0000000
--- a/testsuite/tests/typing-gadts/pr5989.ml.reference
+++ /dev/null
@@ -1,24 +0,0 @@
-
-#       type (_, _) t = Any : ('a, 'b) t | Eq : ('a, 'a) t
-#                   module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end
-#       Characters 40-65:
-  .......................................function
-    | Any -> "Any"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-val f : (M.s, [ `A | `B ]) t -> string = <fun>
-#   Exception: Match_failure ("//toplevel//", 14, 39).
-#                     module N :
-  sig
-    type s = private < a : int; .. >
-    val eq : (s, < a : int; b : bool >) t
-  end
-#       Characters 50-75:
-  .................................................function
-    | Any -> "Any"
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-val f : (N.s, < a : int; b : bool >) t -> string = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/pr5997.ml b/testsuite/tests/typing-gadts/pr5997.ml
index 81eec13748343f9557d279bebceabaaea032ff10..1e293ef01cd4a70ddf48b63d539cf46c6f543f43 100644 (file)
--- a/testsuite/tests/typing-gadts/pr5997.ml
+++ b/testsuite/tests/typing-gadts/pr5997.ml
@@ -14,6 +14,16 @@ end = struct
 end;;
 
 match M.comp with | Diff -> false;;
+[%%expect{|
+type (_, _) comp = Eq : ('a, 'a) comp | Diff : ('a, 'b) comp
+module U : sig type t = T end
+module M : sig type t = T val comp : (U.t, t) comp end
+Line _, characters 0-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+Exception: Match_failure ("", 16, 0).
+|}];;
 
 module U = struct type t = {x : int} end;;
 
@@ -26,3 +36,12 @@ end = struct
 end;;
 
 match M.comp with | Diff -> false;;
+[%%expect{|
+module U : sig type t = { x : int; } end
+module M : sig type t = { x : int; } val comp : (U.t, t) comp end
+Line _, characters 0-33:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+Exception: Match_failure ("", 11, 0).
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr5997.ml.reference b/testsuite/tests/typing-gadts/pr5997.ml.reference
deleted file mode 100644 (file)
index 65af9f3..0000000
--- a/testsuite/tests/typing-gadts/pr5997.ml.reference
+++ /dev/null
@@ -1,21 +0,0 @@
-
-#       type (_, _) comp = Eq : ('a, 'a) comp | Diff : ('a, 'b) comp
-#   module U : sig type t = T end
-#               module M : sig type t = T val comp : (U.t, t) comp end
-#   Characters 1-34:
-  match M.comp with | Diff -> false;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-Exception: Match_failure ("//toplevel//", 13, 0).
-#   module U : sig type t = { x : int; } end
-#               module M : sig type t = { x : int; } val comp : (U.t, t) comp end
-#   Characters 1-34:
-  match M.comp with | Diff -> false;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-Exception: Match_failure ("//toplevel//", 22, 0).
-# 

diff --git a/testsuite/tests/typing-gadts/pr6158.ml b/testsuite/tests/typing-gadts/pr6158.ml
index 752380cb376a6c2dd4bc95e55abb881b86623ed4..5a115b7ba6d3462ddc77caed79945bc1c02286db 100644 (file)
--- a/testsuite/tests/typing-gadts/pr6158.ml
+++ b/testsuite/tests/typing-gadts/pr6158.ml
@@ -7,3 +7,13 @@ let f : (int s, int t) eq -> unit = function Refl -> ();;
 
 module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) =
 struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
+[%%expect{|
+type 'a t = T of 'a
+type 'a s = S of 'a
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 45-49:
+Error: This pattern matches values of type (int s, int s) eq
+       but a pattern was expected which matches values of type
+         (int s, int t) eq
+       Type int s is not compatible with type int t
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr6158.ml.principal.reference b/testsuite/tests/typing-gadts/pr6158.ml.principal.reference
deleted file mode 100644 (file)
index c022a46..0000000
--- a/testsuite/tests/typing-gadts/pr6158.ml.principal.reference
+++ /dev/null
@@ -1,19 +0,0 @@
-
-#       type 'a t = T of 'a
-type 'a s = S of 'a
-type (_, _) eq = Refl : ('a, 'a) eq
-#   Characters 46-50:
-  let f : (int s, int t) eq -> unit = function Refl -> ();;
-                                               ^^^^
-Error: This pattern matches values of type (int s, int s) eq
-       but a pattern was expected which matches values of type
-         (int s, int t) eq
-       Type int s is not compatible with type int t 
-#     Characters 120-124:
-  struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
-                                                        ^^^^
-Error: This pattern matches values of type ($0 S.s, $1 S.t) eq
-       but a pattern was expected which matches values of type
-         ('a S.s, 'a S.t) eq
-       The type constructor $0 would escape its scope
-# 

diff --git a/testsuite/tests/typing-gadts/pr6158.ml.reference b/testsuite/tests/typing-gadts/pr6158.ml.reference
deleted file mode 100644 (file)
index 692130f..0000000
--- a/testsuite/tests/typing-gadts/pr6158.ml.reference
+++ /dev/null
@@ -1,19 +0,0 @@
-
-#       type 'a t = T of 'a
-type 'a s = S of 'a
-type (_, _) eq = Refl : ('a, 'a) eq
-#   Characters 46-50:
-  let f : (int s, int t) eq -> unit = function Refl -> ();;
-                                               ^^^^
-Error: This pattern matches values of type (int s, int s) eq
-       but a pattern was expected which matches values of type
-         (int s, int t) eq
-       Type int s is not compatible with type int t 
-#     Characters 120-124:
-  struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;;
-                                                        ^^^^
-Error: This pattern matches values of type ($'a S.s, $'a S.s) eq
-       but a pattern was expected which matches values of type
-         ($'a S.s, $'a S.t) eq
-       The type constructor $'a would escape its scope
-# 

diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml
index dc5bb8c67ed3ad51d8ca9d85cef1e9b05d22d997..bfb644ad19ec73d08c83497fb406a21c49d745a9 100644 (file)
--- a/testsuite/tests/typing-gadts/pr6163.ml
+++ b/testsuite/tests/typing-gadts/pr6163.ml
@@ -13,3 +13,15 @@ let f (Aux x) =
   | Succ (Succ (Succ (Succ Zero))) -> "4"
   | _ -> .  (* error *)
 ;;
+[%%expect{|
+type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
+type 'a pre_nat = [ `Succ of 'a | `Zero ]
+type aux =
+    Aux :
+      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat ->
+      aux
+Line _, characters 4-5:
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it:
+       Succ (Succ (Succ (Succ (Succ Zero))))
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr6163.ml.principal.reference b/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
deleted file mode 100644 (file)
index c1ac7bd..0000000
--- a/testsuite/tests/typing-gadts/pr6163.ml.principal.reference
+++ /dev/null
@@ -1,14 +0,0 @@
-
-#     type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
-# type 'a pre_nat = [ `Succ of 'a | `Zero ]
-#   type aux =
-    Aux :
-      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> 
-      aux
-#                 Characters 162-163:
-    | _ -> .  (* error *)
-      ^
-Error: This match case could not be refuted.
-       Here is an example of a value that would reach it:
-       Succ (Succ (Succ (Succ (Succ Zero))))
-# 

diff --git a/testsuite/tests/typing-gadts/pr6163.ml.reference b/testsuite/tests/typing-gadts/pr6163.ml.reference
deleted file mode 100644 (file)
index c1ac7bd..0000000
--- a/testsuite/tests/typing-gadts/pr6163.ml.reference
+++ /dev/null
@@ -1,14 +0,0 @@
-
-#     type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat
-# type 'a pre_nat = [ `Succ of 'a | `Zero ]
-#   type aux =
-    Aux :
-      [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> 
-      aux
-#                 Characters 162-163:
-    | _ -> .  (* error *)
-      ^
-Error: This match case could not be refuted.
-       Here is an example of a value that would reach it:
-       Succ (Succ (Succ (Succ (Succ Zero))))
-# 

diff --git a/testsuite/tests/typing-gadts/pr6174.ml b/testsuite/tests/typing-gadts/pr6174.ml
index 84f79ba0e5cb9ed9b253d1a7c7af6a974627d602..fcf5c633a2802e3156f588b67f8109df742588f7 100644 (file)
--- a/testsuite/tests/typing-gadts/pr6174.ml
+++ b/testsuite/tests/typing-gadts/pr6174.ml
@@ -1,3 +1,9 @@
 type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
 let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o =
  fun C k -> k (fun x -> x);;
+[%%expect{|
+type _ t = C : ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t
+Line _, characters 24-25:
+Error: This expression has type $0 but an expression was expected of type
+         $1 = ($2 -> $1) -> $1
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr6174.ml.principal.reference b/testsuite/tests/typing-gadts/pr6174.ml.principal.reference
deleted file mode 100644 (file)
index e47a32f..0000000
--- a/testsuite/tests/typing-gadts/pr6174.ml.principal.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-#     Characters 137-138:
-   fun C k -> k (fun x -> x);;
-                          ^
-Error: This expression has type $0 but an expression was expected of type
-         $1 = ($2 -> $1) -> $1
-# 

diff --git a/testsuite/tests/typing-gadts/pr6174.ml.reference b/testsuite/tests/typing-gadts/pr6174.ml.reference
deleted file mode 100644 (file)
index e47a32f..0000000
--- a/testsuite/tests/typing-gadts/pr6174.ml.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-#     Characters 137-138:
-   fun C k -> k (fun x -> x);;
-                          ^
-Error: This expression has type $0 but an expression was expected of type
-         $1 = ($2 -> $1) -> $1
-# 

diff --git a/testsuite/tests/typing-gadts/pr6241.ml b/testsuite/tests/typing-gadts/pr6241.ml
index 4034e4f89193d6029be13ee79e3696240146ade5..ebda191c165dc356ce2853aeae937e6807d21ea0 100644 (file)
--- a/testsuite/tests/typing-gadts/pr6241.ml
+++ b/testsuite/tests/typing-gadts/pr6241.ml
@@ -14,3 +14,17 @@ module A = struct module type T = sig end end;;
 module N = M(A)(A);;
 
 let x = N.f A;;
+
+[%%expect{|
+type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
+Line _, characters 52-74:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+A
+module M :
+  functor (A : sig module type T end) (B : sig module type T end) ->
+    sig val f : ((module A.T), (module B.T)) t -> string end
+module A : sig module type T = sig  end end
+module N : sig val f : ((module A.T), (module A.T)) t -> string end
+Exception: Match_failure ("", 8, 52).
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr6241.ml.principal.reference b/testsuite/tests/typing-gadts/pr6241.ml.principal.reference
deleted file mode 100644 (file)
index cb3095a..0000000
--- a/testsuite/tests/typing-gadts/pr6241.ml.principal.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#       type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
-#           Characters 127-149:
-  ....................................................function
-     | B s -> s
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-A
-module M :
-  functor (A : sig module type T end) (B : sig module type T end) ->
-    sig val f : ((module A.T), (module B.T)) t -> string end
-#   module A : sig module type T = sig  end end
-#   module N : sig val f : ((module A.T), (module A.T)) t -> string end
-#   Exception: Match_failure ("//toplevel//", 7, 52).
-# 

diff --git a/testsuite/tests/typing-gadts/pr6241.ml.reference b/testsuite/tests/typing-gadts/pr6241.ml.reference
deleted file mode 100644 (file)
index cb3095a..0000000
--- a/testsuite/tests/typing-gadts/pr6241.ml.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#       type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t
-#           Characters 127-149:
-  ....................................................function
-     | B s -> s
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-A
-module M :
-  functor (A : sig module type T end) (B : sig module type T end) ->
-    sig val f : ((module A.T), (module B.T)) t -> string end
-#   module A : sig module type T = sig  end end
-#   module N : sig val f : ((module A.T), (module A.T)) t -> string end
-#   Exception: Match_failure ("//toplevel//", 7, 52).
-# 

diff --git a/testsuite/tests/typing-gadts/pr6690.ml b/testsuite/tests/typing-gadts/pr6690.ml
index 151e99550988e4adda59f16c1f08f9348216952e..b9466f68d62df934a9eadae21d328ac5b339ed45 100644 (file)
--- a/testsuite/tests/typing-gadts/pr6690.ml
+++ b/testsuite/tests/typing-gadts/pr6690.ml
@@ -15,6 +15,32 @@ let vexpr (type visit_action)
   | Local -> fun _ -> raise Exit
   | Global -> fun _ -> raise Exit
 ;;
+[%%expect{|
+type 'a visit_action
+type insert
+type 'a local_visit_action
+type ('a, 'result, 'visit_action) context =
+    Local : ('a, 'a * insert, 'a local_visit_action) context
+  | Global : ('a, 'a, 'a visit_action) context
+Line _, characters 4-9:
+Error: This pattern matches values of type
+         ($0, $0 * insert, $0 local_visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       The type constructor $0 would escape its scope
+|}, Principal{|
+type 'a visit_action
+type insert
+type 'a local_visit_action
+type ('a, 'result, 'visit_action) context =
+    Local : ('a, 'a * insert, 'a local_visit_action) context
+  | Global : ('a, 'a, 'a visit_action) context
+Line _, characters 4-10:
+Error: This pattern matches values of type ($1, $1, visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       Type $1 is not compatible with type $0
+|}];;
 
 let vexpr (type visit_action)
     : ('a, 'result, visit_action) context -> 'a -> visit_action =
@@ -22,6 +48,20 @@ let vexpr (type visit_action)
   | Local -> fun _ -> raise Exit
   | Global -> fun _ -> raise Exit
 ;;
+[%%expect{|
+Line _, characters 4-9:
+Error: This pattern matches values of type
+         ($'a, $'a * insert, $'a local_visit_action) context
+       but a pattern was expected which matches values of type
+         ($'a, $'a * insert, visit_action) context
+       The type constructor $'a would escape its scope
+|}, Principal{|
+Line _, characters 4-10:
+Error: This pattern matches values of type ($1, $1, visit_action) context
+       but a pattern was expected which matches values of type
+         ($0, $0 * insert, visit_action) context
+       Type $1 is not compatible with type $0
+|}];;
 
 let vexpr (type result) (type visit_action)
     : (unit, result, visit_action) context -> unit -> visit_action =
@@ -29,3 +69,6 @@ let vexpr (type result) (type visit_action)
   | Local -> fun _ -> raise Exit
   | Global -> fun _ -> raise Exit
 ;;
+[%%expect{|
+val vexpr : (unit, 'a, 'b) context -> unit -> 'b = <fun>
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr6690.ml.principal.reference b/testsuite/tests/typing-gadts/pr6690.ml.principal.reference
deleted file mode 100644 (file)
index 5c9215b..0000000
--- a/testsuite/tests/typing-gadts/pr6690.ml.principal.reference
+++ /dev/null
@@ -1,23 +0,0 @@
-
-#                   type 'a visit_action
-type insert
-type 'a local_visit_action
-type ('a, 'result, 'visit_action) context =
-    Local : ('a, 'a * insert, 'a local_visit_action) context
-  | Global : ('a, 'a, 'a visit_action) context
-#             Characters 137-143:
-    | Global -> fun _ -> raise Exit
-      ^^^^^^
-Error: This pattern matches values of type ($1, $1, visit_action) context
-       but a pattern was expected which matches values of type
-         ($0, $0 * insert, visit_action) context
-       Type $1 is not compatible with type $0 
-#             Characters 145-151:
-    | Global -> fun _ -> raise Exit
-      ^^^^^^
-Error: This pattern matches values of type ($1, $1, visit_action) context
-       but a pattern was expected which matches values of type
-         ($0, $0 * insert, visit_action) context
-       Type $1 is not compatible with type $0 
-#             val vexpr : (unit, 'a, 'b) context -> unit -> 'b = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/pr6690.ml.reference b/testsuite/tests/typing-gadts/pr6690.ml.reference
deleted file mode 100644 (file)
index ee67a09..0000000
--- a/testsuite/tests/typing-gadts/pr6690.ml.reference
+++ /dev/null
@@ -1,25 +0,0 @@
-
-#                   type 'a visit_action
-type insert
-type 'a local_visit_action
-type ('a, 'result, 'visit_action) context =
-    Local : ('a, 'a * insert, 'a local_visit_action) context
-  | Global : ('a, 'a, 'a visit_action) context
-#             Characters 104-109:
-    | Local -> fun _ -> raise Exit
-      ^^^^^
-Error: This pattern matches values of type
-         ($0, $0 * insert, $0 local_visit_action) context
-       but a pattern was expected which matches values of type
-         ($0, $0 * insert, visit_action) context
-       The type constructor $0 would escape its scope
-#             Characters 112-117:
-    | Local -> fun _ -> raise Exit
-      ^^^^^
-Error: This pattern matches values of type
-         ($'a, $'a * insert, $'a local_visit_action) context
-       but a pattern was expected which matches values of type
-         ($'a, $'a * insert, visit_action) context
-       The type constructor $'a would escape its scope
-#             val vexpr : (unit, 'a, 'b) context -> unit -> 'b = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/pr6817.ml b/testsuite/tests/typing-gadts/pr6817.ml
index 73c1f6351e62a8571b576d151d724988e50b716c..c31f975b6bfbc1b79e2799458c4e070303f3d39d 100644 (file)
--- a/testsuite/tests/typing-gadts/pr6817.ml
+++ b/testsuite/tests/typing-gadts/pr6817.ml
@@ -22,3 +22,13 @@ let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s ->
   | Head, CCons (h, _) -> h
   | Tail n', CCons (_, t) -> get_var n' t
 ;;
+
+[%%expect{|
+module A : sig type nil = Cstr end
+type _ s = Nil : A.nil s | Cons : 't s -> ('h -> 't) s
+type ('stack, 'typ) var =
+    Head : (('typ -> 'a) s, 'typ) var
+  | Tail : ('tail s, 'typ) var -> (('b -> 'tail) s, 'typ) var
+type _ lst = CNil : A.nil lst | CCons : 'h * 't lst -> ('h -> 't) lst
+val get_var : ('stk s, 'ret) var -> 'stk lst -> 'ret = <fun>
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr6817.ml.reference b/testsuite/tests/typing-gadts/pr6817.ml.reference
deleted file mode 100644 (file)
index ec47bcc..0000000
--- a/testsuite/tests/typing-gadts/pr6817.ml.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-
-#         module A : sig type nil = Cstr end
-#                         type _ s = Nil : A.nil s | Cons : 't s -> ('h -> 't) s
-type ('stack, 'typ) var =
-    Head : (('typ -> 'a) s, 'typ) var
-  | Tail : ('tail s, 'typ) var -> (('b -> 'tail) s, 'typ) var
-type _ lst = CNil : A.nil lst | CCons : 'h * 't lst -> ('h -> 't) lst
-#           val get_var : ('stk s, 'ret) var -> 'stk lst -> 'ret = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/pr6980.ml b/testsuite/tests/typing-gadts/pr6980.ml
index 7538b25fb1f71e29ce7e79ee0fca16b22fde710d..85b35d8fb68879a5a714e644f33ac20d2f3b1186 100644 (file)
--- a/testsuite/tests/typing-gadts/pr6980.ml
+++ b/testsuite/tests/typing-gadts/pr6980.ml
@@ -9,3 +9,16 @@ type aux = Aux : 'a t second * ('a -> int) -> aux;;
 let it : 'a. [< `Bar | `Foo > `Bar ] as 'a = `Bar;;
 
 let g (Aux(Second, f)) = f it;;
+
+[%%expect{|
+type 'a t = 'a constraint 'a = [< `Bar | `Foo ]
+type 'a s = 'a constraint 'a = [< `Bar | `Baz | `Foo > `Bar ]
+type 'a first = First : 'b t second -> ([< `Bar | `Foo ] as 'b) t first
+and 'a second = Second : [< `Bar | `Baz | `Foo > `Bar ] s second
+type aux = Aux : ([< `Bar | `Foo ] as 'a) t second * ('a -> int) -> aux
+val it : [< `Bar | `Foo > `Bar ] = `Bar
+Line _, characters 27-29:
+Error: This expression has type [< `Bar | `Foo > `Bar ]
+       but an expression was expected of type [< `Bar | `Foo ]
+       Types for tag `Bar are incompatible
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr6980.ml.reference b/testsuite/tests/typing-gadts/pr6980.ml.reference
deleted file mode 100644 (file)
index 5fd8992..0000000
--- a/testsuite/tests/typing-gadts/pr6980.ml.reference
+++ /dev/null
@@ -1,14 +0,0 @@
-
-# type 'a t = 'a constraint 'a = [< `Bar | `Foo ]
-# type 'a s = 'a constraint 'a = [< `Bar | `Baz | `Foo > `Bar ]
-#     type 'a first = First : 'b t second -> ([< `Bar | `Foo ] as 'b) t first
-and 'a second = Second : [< `Bar | `Baz | `Foo > `Bar ] s second
-#   type aux = Aux : ([< `Bar | `Foo ] as 'a) t second * ('a -> int) -> aux
-#   val it : [< `Bar | `Foo > `Bar ] = `Bar
-#   Characters 28-30:
-  let g (Aux(Second, f)) = f it;;
-                             ^^
-Error: This expression has type [< `Bar | `Foo > `Bar ]
-       but an expression was expected of type [< `Bar | `Foo ]
-       Types for tag `Bar are incompatible
-# 

diff --git a/testsuite/tests/typing-gadts/pr6993_bad.ml b/testsuite/tests/typing-gadts/pr6993_bad.ml
index 122b50f33bddc49cce8ec1c1923e6f90d6c18375..65a312badce5050c91db0e39488889f030ad1eea 100644 (file)
--- a/testsuite/tests/typing-gadts/pr6993_bad.ml
+++ b/testsuite/tests/typing-gadts/pr6993_bad.ml
@@ -10,3 +10,15 @@ and B : sig  type t val eq : (B.t list, t) eqp end =
   end;;
 
 f B.eq;;
+
+[%%expect{|
+type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
+Line _, characters 36-66:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Y
+val f : ('a list, 'a) eqp -> unit = <fun>
+module rec A : sig type t = B.t list end
+and B : sig type t val eq : (B.t list, t) eqp end
+Exception: Match_failure ("", 2, 36).
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr6993_bad.ml.reference b/testsuite/tests/typing-gadts/pr6993_bad.ml.reference
deleted file mode 100644 (file)
index cda1b16..0000000
--- a/testsuite/tests/typing-gadts/pr6993_bad.ml.reference
+++ /dev/null
@@ -1,13 +0,0 @@
-
-#   Characters 100-130:
-  let f : ('a list, 'a) eqp -> unit = function N s -> print_string s;;
-                                      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Y
-type (_, _) eqp = Y : ('a, 'a) eqp | N : string -> ('a, 'b) eqp
-val f : ('a list, 'a) eqp -> unit = <fun>
-#               module rec A : sig type t = B.t list end
-and B : sig type t val eq : (B.t list, t) eqp end
-#   Exception: Match_failure ("//toplevel//", 2, 36).
-# 

diff --git a/testsuite/tests/typing-gadts/pr7016.ml b/testsuite/tests/typing-gadts/pr7016.ml
index 2b2eefbbe114f2a1a65b60bb76cd600ecdccd6f3..2dff639e4b2080c4aa58102664f71a26a5dcd25a 100644 (file)
--- a/testsuite/tests/typing-gadts/pr7016.ml
+++ b/testsuite/tests/typing-gadts/pr7016.ml
@@ -3,7 +3,26 @@ type (_, _) t =
   | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t;;
 
 let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+[%%expect{|
+type (_, _) t =
+    Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t
+Line _, characters 9-43:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Nil
+val get1 : ('b * 'a, 'a) t -> 'b = <fun>
+|}];;
 
 let get1' = function
   | (Cons (x, _) : (_ * 'a, 'a) t) -> x
   | Nil -> assert false ;; (* ok *)
+[%%expect{|
+val get1' : ('b * 'a as 'a, 'a) t -> 'b = <fun>
+|}, Principal{|
+Line _, characters 4-7:
+Error: This pattern matches values of type ('b * 'a, 'b * 'a) t
+       but a pattern was expected which matches values of type
+         ('b * 'a, 'a) t
+       The type variable 'a occurs inside 'b * 'a
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr7016.ml.reference b/testsuite/tests/typing-gadts/pr7016.ml.reference
deleted file mode 100644 (file)
index 1176287..0000000
--- a/testsuite/tests/typing-gadts/pr7016.ml.reference
+++ /dev/null
@@ -1,13 +0,0 @@
-
-#     type (_, _) t =
-    Nil : ('tl, 'tl) t
-  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t
-#   Characters 10-44:
-  let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
-           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Nil
-val get1 : ('b * 'a, 'a) t -> 'b = <fun>
-#       val get1' : ('b * 'a as 'a, 'a) t -> 'b = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/pr7160.ml b/testsuite/tests/typing-gadts/pr7160.ml
index 91263dc0cd5581b929538f95ea7bd5684e32bc59..38254892683869a68363cdabcd19133ab465458d 100644 (file)
--- a/testsuite/tests/typing-gadts/pr7160.ml
+++ b/testsuite/tests/typing-gadts/pr7160.ml
@@ -3,3 +3,14 @@ type _ t =
 let rec f = function Int x -> x | Same s -> f s;;
 type 'a tt = 'a t =
   Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt;;
+
+[%%expect{|
+type _ t =
+    Int : int -> int t
+  | String : string -> string t
+  | Same : 'l t -> 'l t
+val f : int t -> int = <fun>
+Line _, characters 0-97:
+Error: This variant or record definition does not match that of type 'a t
+       The types for field Same are not equal.
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr7160.ml.reference b/testsuite/tests/typing-gadts/pr7160.ml.reference
deleted file mode 100644 (file)
index 5d5e925..0000000
--- a/testsuite/tests/typing-gadts/pr7160.ml.reference
+++ /dev/null
@@ -1,12 +0,0 @@
-
-#   type _ t =
-    Int : int -> int t
-  | String : string -> string t
-  | Same : 'l t -> 'l t
-# val f : int t -> int = <fun>
-#   Characters 0-97:
-  type 'a tt = 'a t =
-    Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt..
-Error: This variant or record definition does not match that of type 'a t
-       The types for field Same are not equal.
-# 

diff --git a/testsuite/tests/typing-gadts/pr7214.ml b/testsuite/tests/typing-gadts/pr7214.ml
index ff077b4f3f0d7bf878dc855a0a2339c7177e7c94..736b353e46e099dfd501ec3143b699aa2a485077 100644 (file)
--- a/testsuite/tests/typing-gadts/pr7214.ml
+++ b/testsuite/tests/typing-gadts/pr7214.ml
@@ -6,3 +6,32 @@ let f (type a) (x : a t) =
     let x = (I : a t)
   end in
   () ;;
+[%%expect{|
+type _ t = I : int t
+Line _, characters 9-10:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type a t
+       Type int is not compatible with type a
+|}];;
+
+(* extra example by Stephen Dolan, using recursive modules *)
+(* Should not be allowed! *)
+type (_,_) eq = Refl : ('a, 'a) eq;;
+
+let bad (type a) =
+ let module N = struct
+   module rec M : sig
+     val e : (int, a) eq
+   end = struct
+     let (Refl : (int, a) eq) = M.e  (* must fail for soundness *)
+     let e : (int, a) eq = Refl
+   end
+ end in N.M.e
+;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 10-14:
+Error: This pattern matches values of type (int, int) eq
+       but a pattern was expected which matches values of type (int, a) eq
+       Type int is not compatible with type a
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr7214.ml.reference b/testsuite/tests/typing-gadts/pr7214.ml.reference
deleted file mode 100644 (file)
index b021123..0000000
--- a/testsuite/tests/typing-gadts/pr7214.ml.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-
-# type _ t = I : int t
-#             Characters 61-62:
-      let (I : a t) = x     (* fail because of toplevel let *)
-           ^
-Error: This pattern matches values of type int t
-       but a pattern was expected which matches values of type a t
-       Type int is not compatible with type a 
-# 

diff --git a/testsuite/tests/typing-gadts/pr7222.ml b/testsuite/tests/typing-gadts/pr7222.ml
index 26b8a0371bba6bf251d1a8a5b16f6fb3f9219e51..d26539de16411f31e1ca45968724a290900a290a 100644 (file)
--- a/testsuite/tests/typing-gadts/pr7222.ml
+++ b/testsuite/tests/typing-gadts/pr7222.ml
@@ -8,3 +8,29 @@ type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t;;
 let undetected: ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = fun sh i j ->
   let Cons(Elt dim, _) = sh in ()
 ;;
+
+[%%expect{|
+type +'a n = private int
+type nil = private Nil_type
+type (_, _) elt =
+    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
+  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
+Line _, characters 11-18:
+Error: This pattern matches values of type ($Cons_'x, 'a -> $Cons_'x) elt
+       but a pattern was expected which matches values of type
+         ($Cons_'x, 'a -> $'b -> nil) elt
+       The type constructor $'b would escape its scope
+|}, Principal{|
+type +'a n = private int
+type nil = private Nil_type
+type (_, _) elt =
+    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
+  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
+type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
+Line _, characters 6-22:
+Error: This pattern matches values of type ('a -> $0 -> nil) t
+       but a pattern was expected which matches values of type
+         ('a -> 'b -> nil) t
+       The type constructor $0 would escape its scope
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr7222.ml.principal.reference b/testsuite/tests/typing-gadts/pr7222.ml.principal.reference
deleted file mode 100644 (file)
index 3f28c3b..0000000
--- a/testsuite/tests/typing-gadts/pr7222.ml.principal.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#           type +'a n = private int
-type nil = private Nil_type
-type (_, _) elt =
-    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
-  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
-type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
-#       Characters 83-99:
-    let Cons(Elt dim, _) = sh in ()
-        ^^^^^^^^^^^^^^^^
-Error: This pattern matches values of type ('a -> $0 -> nil) t
-       but a pattern was expected which matches values of type
-         ('a -> 'b -> nil) t
-       The type constructor $0 would escape its scope
-# 

diff --git a/testsuite/tests/typing-gadts/pr7222.ml.reference b/testsuite/tests/typing-gadts/pr7222.ml.reference
deleted file mode 100644 (file)
index 1502595..0000000
--- a/testsuite/tests/typing-gadts/pr7222.ml.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#           type +'a n = private int
-type nil = private Nil_type
-type (_, _) elt =
-    Elt_fine : 'nat n -> ('l, 'nat * 'l) elt
-  | Elt : 'nat n -> ('l, 'nat -> 'l) elt
-type _ t = Nil : nil t | Cons : ('x, 'fx) elt * 'x t -> 'fx t
-#       Characters 88-95:
-    let Cons(Elt dim, _) = sh in ()
-             ^^^^^^^
-Error: This pattern matches values of type ($Cons_'x, 'a -> $Cons_'x) elt
-       but a pattern was expected which matches values of type
-         ($Cons_'x, 'a -> $'b -> nil) elt
-       The type constructor $'b would escape its scope
-# 

diff --git a/testsuite/tests/typing-gadts/pr7230.ml b/testsuite/tests/typing-gadts/pr7230.ml
index 6e588b648f24ecf9e33d68358c17e8a65e29c817..16f652ce99c6487505c18b5e12a8eae2d8f8f491 100644 (file)
--- a/testsuite/tests/typing-gadts/pr7230.ml
+++ b/testsuite/tests/typing-gadts/pr7230.ml
@@ -2,3 +2,8 @@ type _ t = T : int t;;
 
 (* Should raise Not_found *)
 let _ = match (raise Not_found : float t) with _ -> .;;
+
+[%%expect{|
+type _ t = T : int t
+Exception: Not_found.
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr7230.ml.reference b/testsuite/tests/typing-gadts/pr7230.ml.reference
deleted file mode 100644 (file)
index a05bcdf..0000000
--- a/testsuite/tests/typing-gadts/pr7230.ml.reference
+++ /dev/null
@@ -1,4 +0,0 @@
-
-# type _ t = T : int t
-#     Exception: Not_found.
-# 

diff --git a/testsuite/tests/typing-gadts/pr7234.ml b/testsuite/tests/typing-gadts/pr7234.ml
index a8a06d2aea6b9b3cbafd86b6afdae8e9e61e4b67..622aef9066b620cbb2593a69cf64552c93068f67 100644 (file)
--- a/testsuite/tests/typing-gadts/pr7234.ml
+++ b/testsuite/tests/typing-gadts/pr7234.ml
@@ -1,7 +1,24 @@
 type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq;;
 type 'a t;;
 let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq
+type 'a t
+Line _, characters 15-40:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+val f : ('a, 'a t) eq -> int = <fun>
+|}];;
 
 module F (T : sig type _ t end) = struct
  let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
 end;;
+[%%expect{|
+Line _, characters 16-43:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Eq
+module F :
+  functor (T : sig type _ t end) -> sig val f : ('a, 'a T.t) eq -> int end
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr7234.ml.principal.reference b/testsuite/tests/typing-gadts/pr7234.ml.principal.reference
deleted file mode 100644 (file)
index 6210e21..0000000
--- a/testsuite/tests/typing-gadts/pr7234.ml.principal.reference
+++ /dev/null
@@ -1,19 +0,0 @@
-
-# type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq
-# type 'a t
-# Characters 15-40:
-  let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
-                 ^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-val f : ('a, 'a t) eq -> int = <fun>
-#       Characters 58-85:
-   let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
-                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-module F :
-  functor (T : sig type _ t end) -> sig val f : ('a, 'a T.t) eq -> int end
-# 

diff --git a/testsuite/tests/typing-gadts/pr7234.ml.reference b/testsuite/tests/typing-gadts/pr7234.ml.reference
deleted file mode 100644 (file)
index 6210e21..0000000
--- a/testsuite/tests/typing-gadts/pr7234.ml.reference
+++ /dev/null
@@ -1,19 +0,0 @@
-
-# type (_, _) eq = Eq : ('a, 'a) eq | Neq : int -> ('a, 'b) eq
-# type 'a t
-# Characters 15-40:
-  let f (type a) (Neq n : (a, a t) eq) = n;;   (* warn! *)
-                 ^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-val f : ('a, 'a t) eq -> int = <fun>
-#       Characters 58-85:
-   let f (type a) (Neq n : (a, a T.t) eq) = n  (* warn! *)
-                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Eq
-module F :
-  functor (T : sig type _ t end) -> sig val f : ('a, 'a T.t) eq -> int end
-# 

diff --git a/testsuite/tests/typing-gadts/pr7260.ml b/testsuite/tests/typing-gadts/pr7260.ml
new file mode 100644 (file)
index 0000000..77daa1f
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7260.ml
@@ -0,0 +1,21 @@
+type bar = < bar: unit >
+
+type _ ty = Int : int ty
+
+type dyn = Dyn : 'a ty -> dyn;;
+
+class foo =
+  object (this)
+    method foo (Dyn ty) =
+      match ty with
+      | Int -> (this :> bar)
+  end;;  (* fail, but not for scope *)
+
+[%%expect{|
+type bar = < bar : unit >
+type _ ty = Int : int ty
+type dyn = Dyn : 'a ty -> dyn
+Line _, characters 0-108:
+Error: This class should be virtual.
+       The following methods are undefined : bar
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr7269.ml b/testsuite/tests/typing-gadts/pr7269.ml
new file mode 100644 (file)
index 0000000..051b4dc
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7269.ml
@@ -0,0 +1,71 @@
+type s = [`A | `B] and sub = [`B];;
+type +'a t = T : [< `Conj of 'a & sub | `Other of string] -> 'a t;; (* ok *)
+
+let f (T (`Other msg) : s t) = print_string msg;;
+let _ = f (T (`Conj `B) :> s t);; (* warn *)
+[%%expect{|
+type s = [ `A | `B ]
+and sub = [ `B ]
+type +'a t = T : [< `Conj of 'a & sub | `Other of string ] -> 'a t
+Line _, characters 6-47:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+T (`Conj _)
+val f : s t -> unit = <fun>
+Exception: Match_failure ("", 4, 6).
+|}];;
+
+module M : sig
+  type s
+  type t = T : [< `Conj of int & s | `Other of string] -> t
+  val x : t
+end = struct
+  type s = int
+  type t = T : [< `Conj of int | `Other of string] -> t
+  let x = T (`Conj 42)
+end;;
+
+let () = M.(match x with T (`Other msg) -> print_string msg);; (* warn *)
+[%%expect{|
+module M :
+  sig
+    type s
+    type t = T : [< `Conj of int & s | `Other of string ] -> t
+    val x : t
+  end
+Line _, characters 12-59:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+T (`Conj _)
+Exception: Match_failure ("", 11, 12).
+|}];;
+
+
+module M : sig
+  type s
+  type elim =
+      { ex : 'a . ([<`Conj of int & s | `Other of string] as 'a) -> unit }
+  val e : elim -> unit
+end = struct
+  type s = int
+  type elim =
+      { ex : 'a . (([<`Conj of int | `Other of string] as 'a) -> unit) }
+  let e { ex } = ex (`Conj 42 : [`Conj of int])
+end;;
+
+let () = M.(e { ex = fun (`Other msg) -> print_string msg });; (* warn *)
+[%%expect{|
+module M :
+  sig
+    type s
+    type elim = {
+      ex : 'a. ([< `Conj of int & s | `Other of string ] as 'a) -> unit;
+    }
+    val e : elim -> unit
+  end
+Line _, characters 21-57:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+`Conj _
+Exception: Match_failure ("", 13, 21).
+|}];;

diff --git a/testsuite/tests/typing-gadts/pr7298.ml b/testsuite/tests/typing-gadts/pr7298.ml
new file mode 100644 (file)
index 0000000..695fc3c
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7298.ml
@@ -0,0 +1,14 @@
+type t = T : t;;
+
+module M : sig
+  type free = < bar : t -> unit; foo : free -> unit >
+end = struct
+  class free = object (self : 'self)
+    method foo self = ()
+    method bar T = self#foo self
+  end
+end;;
+[%%expect{|
+type t = T : t
+module M : sig type free = < bar : t -> unit; foo : free -> unit > end
+|}]

diff --git a/testsuite/tests/typing-gadts/pr7374.ml b/testsuite/tests/typing-gadts/pr7374.ml
new file mode 100644 (file)
index 0000000..b7243fb
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7374.ml
@@ -0,0 +1,49 @@
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+
+module type S = sig
+  type 'a t constraint 'a = [`Rec of 'b]
+end;;
+[%%expect{|
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+module type S = sig type 'a t constraint 'a = [ `Rec of 'b ] end
+|}]
+
+module Fix (X : S) : sig
+  type t
+  val uniq : ('a, [`Rec of 'a] X.t) eq -> ('a, t) eq
+end = struct
+  type t = [`Rec of 'a] X.t as 'a
+  let uniq : type a . (a, [`Rec of a] X.t) eq -> (a, t) eq =
+    fun Refl -> Refl
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 16-20:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, t) eq
+       Type a is not compatible with type t = [ `Rec of 'a ] X.t as 'a
+|}]
+
+(* trigger segfault
+module Id = struct
+  type 'a t = 'b constraint 'a = [ `Rec of 'b ]
+end
+
+module Bad = Fix(Id)
+
+let segfault () =
+  print_endline (cast (trans (Bad.uniq Refl) (Bad.uniq Refl)) 0)
+*)
+
+(* addendum: ensure that hidden paths are checked too *)
+module F (X : sig type 'a t end) = struct
+  open X
+  let f : type a b. (a, b t) eq -> (b, a t) eq -> (a, a t t) eq =
+    fun Refl Refl -> Refl;;
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 21-25:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, a X.t X.t) eq
+       Type a = b X.t is not compatible with type a X.t X.t
+       Type b is not compatible with type a X.t
+|}]

diff --git a/testsuite/tests/typing-gadts/pr7378.ml b/testsuite/tests/typing-gadts/pr7378.ml
new file mode 100644 (file)
index 0000000..3d8a292
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7378.ml
@@ -0,0 +1,23 @@
+module X = struct
+  type t =
+    | A : 'a * 'b * ('a -> unit) -> t
+end;;
+[%%expect{|
+module X : sig type t = A : 'a * 'b * ('a -> unit) -> t end
+|}]
+
+module Y = struct
+  type t = X.t =
+    | A : 'a * 'b * ('b -> unit) -> t
+end;; (* should fail *)
+[%%expect{|
+Line _, characters 2-54:
+Error: This variant or record definition does not match that of type X.t
+       The types for field A are not equal.
+|}]
+
+(* would segfault
+let () =
+  match Y.A (1, "", print_string) with
+  | X.A (x, y, f) -> f x
+*)

diff --git a/testsuite/tests/typing-gadts/pr7381.ml b/testsuite/tests/typing-gadts/pr7381.ml
new file mode 100644 (file)
index 0000000..79cc245
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7381.ml
@@ -0,0 +1,15 @@
+type (_,_) eql = Refl : ('a, 'a) eql;;
+[%%expect{|
+type (_, _) eql = Refl : ('a, 'a) eql
+|}]
+
+let f : type t. (int, t) eql * (t, string) eql -> unit = function _ -> . ;;
+[%%expect{|
+val f : (int, 't) eql * ('t, string) eql -> unit = <fun>
+|}]
+
+let f : type t. ((int, t) eql * (t, string) eql) option -> unit =
+  function None -> () ;;
+[%%expect{|
+val f : ((int, 't) eql * ('t, string) eql) option -> unit = <fun>
+|}]

diff --git a/testsuite/tests/typing-gadts/pr7390.ml b/testsuite/tests/typing-gadts/pr7390.ml
new file mode 100644 (file)
index 0000000..b421ec5
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7390.ml
@@ -0,0 +1,25 @@
+type empty = Empty and filled = Filled
+type ('a,'fout,'fin) opt =
+  | N : ('a, 'f, 'f) opt
+  | Y : 'a -> ('a, filled, empty) opt
+type 'fill either =
+  | Either : (string, 'fill, 'f) opt * (int, 'f, empty) opt -> 'fill either;;
+[%%expect{|
+type empty = Empty
+and filled = Filled
+type ('a, 'fout, 'fin) opt =
+    N : ('a, 'f, 'f) opt
+  | Y : 'a -> ('a, filled, empty) opt
+type 'fill either =
+    Either : (string, 'fill, 'f) opt * (int, 'f, empty) opt -> 'fill either
+|}]
+
+let f (* : filled either -> string *) =
+  fun (Either (Y a, N)) -> a;;
+[%%expect{|
+Line _, characters 2-28:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Either (N, Y _)
+val f : filled either -> string = <fun>
+|}]

diff --git a/testsuite/tests/typing-gadts/pr7391.ml b/testsuite/tests/typing-gadts/pr7391.ml
new file mode 100644 (file)
index 0000000..ace84b5
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7391.ml
@@ -0,0 +1,76 @@
+class virtual child1 parent =
+  object
+    method private parent = parent
+  end
+
+class virtual child2 =
+  object(_ : 'self)
+    constraint 'parent = < previous: 'self option; .. >
+    method private virtual parent: 'parent
+  end
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+class virtual child1 : 'a -> object method private parent : 'a end
+class virtual child2 :
+  object ('a)
+    method private virtual parent : < previous : 'a option; .. >
+  end
+- : < child : child2; previous : child2 option > = <obj>
+|}]
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child (_ : unit) =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+- : < child : unit -> child2; previous : child2 option > = <obj>
+|}]
+
+(* Worked in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child () =
+      object
+        inherit child1 self
+        inherit child2
+      end
+  end;;
+[%%expect{|
+- : < child : unit -> child2; previous : child2 option > = <obj>
+|}]
+
+(* Didn't work in 4.03 *)
+let _ =
+  object(self)
+    method previous = None
+    method child =
+      let o =
+      object
+        inherit child1 self
+        inherit child2
+      end
+      in o
+  end;;
+[%%expect{|
+Line _, characters 16-22:
+Error: The method parent has type < child : 'a; previous : 'b option >
+       but is expected to have type < previous : < .. > option; .. >
+       Self type cannot escape its class
+|}]

diff --git a/testsuite/tests/typing-gadts/pr7397.ml b/testsuite/tests/typing-gadts/pr7397.ml
new file mode 100644 (file)
index 0000000..3960514
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7397.ml
@@ -0,0 +1,25 @@
+type +'a t
+
+class type a = object
+ method b : b
+end
+
+and b = object
+ method a : a
+end
+
+type _ response =
+ | C : #a t response;;
+[%%expect{|
+type +'a t
+class type a = object method b : b end
+and b = object method a : a end
+type _ response = C : #a t response
+|}]
+
+let f (type a) (a : a response) =
+ match a with
+ | C -> 0;;
+[%%expect{|
+val f : 'a response -> int = <fun>
+|}]

diff --git a/testsuite/tests/typing-gadts/term-conv.ml b/testsuite/tests/typing-gadts/term-conv.ml
index 9b53cd6ea8d476b8907b62e6870d24daffa4de66..4994bdfd28c483e3ab3ebdeee93d24916f4ea43a 100644 (file)
--- a/testsuite/tests/typing-gadts/term-conv.ml
+++ b/testsuite/tests/typing-gadts/term-conv.ml
@@ -26,6 +26,21 @@ module Typeable = struct
   let gcast : type t t'. t ty -> t' ty -> t -> t' = fun t t' x ->
     match check_eq t t' with Eq -> x
 end;;
+[%%expect{|
+module Typeable :
+  sig
+    type 'a ty =
+        Int : int ty
+      | String : string ty
+      | List : 'a ty -> 'a list ty
+      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
+    type (_, _) eq = Eq : ('a, 'a) eq
+    exception CastFailure
+    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
+    val gcast : 't ty -> 't' ty -> 't -> 't'
+  end
+|}];;
 
 module HOAS = struct
   open Typeable
@@ -42,6 +57,17 @@ module HOAS = struct
     | Lam (_, f) -> fun x -> intp (f (Con x))
     | App (f, a) -> intp f (intp a)
 end;;
+[%%expect{|
+module HOAS :
+  sig
+    type _ term =
+        Tag : 't Typeable.ty * int -> 't term
+      | Con : 't -> 't term
+      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
+      | App : ('s -> 't) term * 's term -> 't term
+    val intp : 't term -> 't
+  end
+|}];;
 
 module DeBruijn = struct
   type ('env,'t) ix =
@@ -74,6 +100,25 @@ module DeBruijn = struct
     | Lam b  -> fun x -> intp b (Push (s, x))
     | App(f,a) -> intp f s (intp a s)
 end;;
+[%%expect{|
+module DeBruijn :
+  sig
+    type ('env, 't) ix =
+        ZeroIx : ('env * 't, 't) ix
+      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
+    val to_int : ('env, 't) ix -> int
+    type ('env, 't) term =
+        Var : ('env, 't) ix -> ('env, 't) term
+      | Con : 't -> ('env, 't) term
+      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+    type _ stack =
+        Empty : unit stack
+      | Push : 'env stack * 't -> ('env * 't) stack
+    val prj : ('env, 't) ix -> 'env stack -> 't
+    val intp : ('env, 't) term -> 'env stack -> 't
+  end
+|}];;
 
 module Convert = struct
   type (_,_) layout =
@@ -113,6 +158,21 @@ module Convert = struct
 
   let convert t = cvt EmptyLayout t
 end;;
+[%%expect{|
+module Convert :
+  sig
+    type (_, _) layout =
+        EmptyLayout : ('env, unit) layout
+      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
+          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
+    val size : ('env, 'env') layout -> int
+    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
+    val prj :
+      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
+    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
+    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
+  end
+|}];;
 
 module Main = struct
   open HOAS
@@ -137,3 +197,22 @@ module Main = struct
   let plus_2_3' = convert (plus_2_3 Typeable.Int)
   let eval_plus_2_3' = DeBruijn.intp plus_2_3' DeBruijn.Empty succ 0
 end;;
+[%%expect{|
+module Main :
+  sig
+    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
+    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val plus :
+      'a Typeable.ty ->
+      ((('a -> 'a) -> 'a -> 'a) ->
+       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
+      HOAS.term
+    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val i' : (unit, int -> int) DeBruijn.term
+    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
+    val eval_plus_2_3' : int
+  end
+|}];;

diff --git a/testsuite/tests/typing-gadts/term-conv.ml.principal.reference b/testsuite/tests/typing-gadts/term-conv.ml.principal.reference
deleted file mode 100644 (file)
index cff10f1..0000000
--- a/testsuite/tests/typing-gadts/term-conv.ml.principal.reference
+++ /dev/null
@@ -1,71 +0,0 @@
-
-#                                                       module Typeable :
-  sig
-    type 'a ty =
-        Int : int ty
-      | String : string ty
-      | List : 'a ty -> 'a list ty
-      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
-    type (_, _) eq = Eq : ('a, 'a) eq
-    exception CastFailure
-    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
-    val gcast : 't ty -> 't' ty -> 't -> 't'
-  end
-#                               module HOAS :
-  sig
-    type _ term =
-        Tag : 't Typeable.ty * int -> 't term
-      | Con : 't -> 't term
-      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
-      | App : ('s -> 't) term * 's term -> 't term
-    val intp : 't term -> 't
-  end
-#                                                               module DeBruijn :
-  sig
-    type ('env, 't) ix =
-        ZeroIx : ('env * 't, 't) ix
-      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
-    val to_int : ('env, 't) ix -> int
-    type ('env, 't) term =
-        Var : ('env, 't) ix -> ('env, 't) term
-      | Con : 't -> ('env, 't) term
-      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
-      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
-    type _ stack =
-        Empty : unit stack
-      | Push : 'env stack * 't -> ('env * 't) stack
-    val prj : ('env, 't) ix -> 'env stack -> 't
-    val intp : ('env, 't) term -> 'env stack -> 't
-  end
-#                                                                             module Convert :
-  sig
-    type (_, _) layout =
-        EmptyLayout : ('env, unit) layout
-      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
-          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
-    val size : ('env, 'env') layout -> int
-    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
-    val prj :
-      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
-    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
-    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
-  end
-#                                               module Main :
-  sig
-    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
-    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val plus :
-      'a Typeable.ty ->
-      ((('a -> 'a) -> 'a -> 'a) ->
-       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
-      HOAS.term
-    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val i' : (unit, int -> int) DeBruijn.term
-    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
-    val eval_plus_2_3' : int
-  end
-# 

diff --git a/testsuite/tests/typing-gadts/term-conv.ml.reference b/testsuite/tests/typing-gadts/term-conv.ml.reference
deleted file mode 100644 (file)
index cff10f1..0000000
--- a/testsuite/tests/typing-gadts/term-conv.ml.reference
+++ /dev/null
@@ -1,71 +0,0 @@
-
-#                                                       module Typeable :
-  sig
-    type 'a ty =
-        Int : int ty
-      | String : string ty
-      | List : 'a ty -> 'a list ty
-      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
-      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
-    type (_, _) eq = Eq : ('a, 'a) eq
-    exception CastFailure
-    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
-    val gcast : 't ty -> 't' ty -> 't -> 't'
-  end
-#                               module HOAS :
-  sig
-    type _ term =
-        Tag : 't Typeable.ty * int -> 't term
-      | Con : 't -> 't term
-      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
-      | App : ('s -> 't) term * 's term -> 't term
-    val intp : 't term -> 't
-  end
-#                                                               module DeBruijn :
-  sig
-    type ('env, 't) ix =
-        ZeroIx : ('env * 't, 't) ix
-      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
-    val to_int : ('env, 't) ix -> int
-    type ('env, 't) term =
-        Var : ('env, 't) ix -> ('env, 't) term
-      | Con : 't -> ('env, 't) term
-      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
-      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
-    type _ stack =
-        Empty : unit stack
-      | Push : 'env stack * 't -> ('env * 't) stack
-    val prj : ('env, 't) ix -> 'env stack -> 't
-    val intp : ('env, 't) term -> 'env stack -> 't
-  end
-#                                                                             module Convert :
-  sig
-    type (_, _) layout =
-        EmptyLayout : ('env, unit) layout
-      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
-          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
-    val size : ('env, 'env') layout -> int
-    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
-    val prj :
-      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
-    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
-    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
-  end
-#                                               module Main :
-  sig
-    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
-    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val plus :
-      'a Typeable.ty ->
-      ((('a -> 'a) -> 'a -> 'a) ->
-       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
-      HOAS.term
-    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
-    val i' : (unit, int -> int) DeBruijn.term
-    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
-    val eval_plus_2_3' : int
-  end
-# 

diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml
index 61cfd39f80e13a5c8bd2cd98d2e83170f37dbc47..3003840f9bc43e87489f619c58889b2e6b8ea75c 100644 (file)
--- a/testsuite/tests/typing-gadts/test.ml
+++ b/testsuite/tests/typing-gadts/test.ml
@@ -27,6 +27,19 @@ module Exp =
       | Abs _ -> 5
   end
 ;;
+[%%expect{|
+module Exp :
+  sig
+    type _ t =
+        IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t
+    val eval : 's t -> 's
+    val discern : 'a t -> int
+  end
+|}];;
 
 module List =
   struct
@@ -46,6 +59,16 @@ module List =
         | Cons (a,b) -> length b
   end
 ;;
+[%%expect{|
+module List :
+  sig
+    type zero
+    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
+    val head : ('a * 'b) t -> 'a
+    val tail : ('a * 'b) t -> 'b t
+    val length : 'a t -> int
+  end
+|}];;
 
 module Nonexhaustive =
   struct
@@ -75,6 +98,25 @@ module Nonexhaustive =
         | Bar _, Bar _ -> true
   end
 ;;
+[%%expect{|
+Line _, characters 6-34:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+C1 _
+Line _, characters 6-77:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Bar _, Foo _)
+module Nonexhaustive :
+  sig
+    type 'a u = C1 : int -> int u | C2 : bool -> bool u
+    type 'a v = C1 : int -> int v
+    val unexhaustive : 's u -> 's
+    module M : sig type t type u end
+    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
+    val same_type : 's t * 's t -> bool
+  end
+|}];;
 
 module Exhaustive =
   struct
@@ -90,23 +132,63 @@ module Exhaustive =
         | Bar _, Bar _ -> true
   end
 ;;
+[%%expect{|
+module Exhaustive :
+  sig
+    type t = int
+    type u = bool
+    type 'a v = Foo : t -> t v | Bar : u -> u v
+    val same_type : 's v * 's v -> bool
+  end
+|}];;
 
 module PR6862 = struct
   class c (Some x) = object method x : int = x end
   type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
   class d (Just x) = object method x : int = x end
 end;;
+[%%expect{|
+Line _, characters 10-18:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+None
+Line _, characters 10-18:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Nothing
+module PR6862 :
+  sig
+    class c : int option -> object method x : int end
+    type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
+    class d : int opt -> object method x : int end
+  end
+|}];;
 
 module Exhaustive2 = struct
   type _ t = Int : int t
   let f (x : bool t option) = match x with None -> ()
 end;;
+[%%expect{|
+module Exhaustive2 :
+  sig type _ t = Int : int t val f : bool t option -> unit end
+|}];;
 
 module PR6220 = struct
   type 'a t = I : int t | F : float t
   let f : int t -> int = function I -> 1
-  let g : int t -> int = function I -> 1 | _ -> 2 (* no warning *)
+  let g : int t -> int = function I -> 1 | _ -> 2 (* warn *)
 end;;
+[%%expect{|
+Line _, characters 43-44:
+Warning 56: this match case is unreachable.
+Consider replacing it with a refutation case '<pat> -> .'
+module PR6220 :
+  sig
+    type 'a t = I : int t | F : float t
+    val f : int t -> int
+    val g : int t -> int
+  end
+|}];;
 
 module PR6403 = struct
   type (_, _) eq = Refl : ('a, 'a) eq
@@ -116,6 +198,15 @@ module PR6403 = struct
   let notequal : ((int, bool) eq, empty) sum -> empty = function
     | Right empty -> empty
 end;;
+[%%expect{|
+module PR6403 :
+  sig
+    type (_, _) eq = Refl : ('a, 'a) eq
+    type empty = { bottom : 'a. 'a; }
+    type ('a, 'b) sum = Left of 'a | Right of 'b
+    val notequal : ((int, bool) eq, empty) sum -> empty
+  end
+|}];;
 
 module PR6437 = struct
   type ('a, 'b) ctx =
@@ -132,6 +223,16 @@ module PR6437 = struct
     | _ -> .
   (*| Nil, _ -> (assert false) *)  (* warns, but shouldn't *)
 end;;
+[%%expect{|
+module PR6437 :
+  sig
+    type ('a, 'b) ctx =
+        Nil : (unit, unit) ctx
+      | Cons : ('a, 'b) ctx -> ('a * unit, 'b * unit) ctx
+    type 'a var = O : ('a * unit) var | S : 'a var -> ('a * unit) var
+    val f : ('g1, 'g2) ctx * 'g1 var -> 'g2 var
+  end
+|}];;
 
 module PR6801 = struct
   type _ value =
@@ -143,6 +244,20 @@ module PR6801 = struct
     match x with
     | String s -> print_endline s (* warn : Any *)
 end;;
+[%%expect{|
+Line _, characters 4-50:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Any
+module PR6801 :
+  sig
+    type _ value =
+        String : string -> string value
+      | Float : float -> float value
+      | Any
+    val print_string_value : string value -> unit
+  end
+|}];;
 
 module Existential_escape =
   struct
@@ -151,6 +266,12 @@ module Existential_escape =
     let eval (D x) = x
   end
 ;;
+[%%expect{|
+Line _, characters 21-22:
+Error: This expression has type $D_'a t
+       but an expression was expected of type 'a
+       The type constructor $D_'a would escape its scope
+|}];;
 
 module Rectype =
   struct
@@ -159,6 +280,10 @@ module Rectype =
       fun C -> () (* here s = s*s! *)
   end
 ;;
+[%%expect{|
+module Rectype :
+  sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end
+|}];;
 
 module Or_patterns =
   struct
@@ -172,6 +297,12 @@ module Or_patterns =
 
 end
 ;;
+[%%expect{|
+Line _, characters 11-19:
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type s t
+       Type int is not compatible with type s
+|}];;
 
 module Polymorphic_variants =
   struct
@@ -185,6 +316,13 @@ module Polymorphic_variants =
         | `A, BoolLit _ -> ()
   end
 ;;
+[%%expect{|
+module Polymorphic_variants :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val eval : [ `A ] * 's t -> unit
+  end
+|}];;
 
 module Propagation = struct
   type _ t =
@@ -202,6 +340,16 @@ module Propagation = struct
     in r
 end
 ;;
+[%%expect{|
+module Propagation :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val check : 's t -> 's
+  end
+|}, Principal{|
+Line _, characters 19-20:
+Error: This expression has type bool but an expression was expected of type s
+|}];;
 
 module Normal_constrs = struct
   type a = A
@@ -209,6 +357,15 @@ module Normal_constrs = struct
 
   let f = function A -> 1 | B -> 2
 end;;
+[%%expect{|
+Line _, characters 28-29:
+Error: This variant pattern is expected to have type a
+       The constructor B does not belong to type a
+|}, Principal{|
+Line _, characters 28-29:
+Error: This pattern matches values of type b
+       but a pattern was expected which matches values of type a
+|}];;
 
 module PR6849 = struct
   type 'a t = Foo : int t
@@ -216,6 +373,11 @@ module PR6849 = struct
   let f : int -> int = function
       Foo -> 5
 end;;
+[%%expect{|
+Line _, characters 6-9:
+Error: This pattern matches values of type 'a t
+       but a pattern was expected which matches values of type int
+|}];;
 
 type _ t = Int : int t ;;
 
@@ -224,67 +386,139 @@ let ky x y = ignore (x = y); x ;;
 let test : type a. a t -> a =
   function Int -> ky (1 : a) 1
 ;;
+[%%expect{|
+type _ t = Int : int t
+val ky : 'a -> 'a -> 'a = <fun>
+val test : 'a t -> 'a = <fun>
+|}];;
 
 let test : type a. a t -> _ =
   function Int -> 1       (* ok *)
 ;;
+[%%expect{|
+val test : 'a t -> int = <fun>
+|}];;
 
 let test : type a. a t -> _ =
   function Int -> ky (1 : a) 1  (* fails *)
 ;;
+[%%expect{|
+Line _, characters 18-30:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let test : type a. a t -> a = fun x ->
   let r = match x with Int -> ky (1 : a) 1  (* fails *)
   in r
 ;;
+[%%expect{|
+Line _, characters 30-42:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
 let test : type a. a t -> a = fun x ->
   let r = match x with Int -> ky 1 (1 : a)  (* fails *)
   in r
 ;;
+[%%expect{|
+Line _, characters 30-42:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
 let test (type a) x =
   let r = match (x : a t) with Int -> ky 1 1
   in r
 ;;
+[%%expect{|
+val test : 'a t -> int = <fun>
+|}];;
+
 let test : type a. a t -> a = fun x ->
   let r = match x with Int -> (1 : a)       (* ok! *)
   in r
 ;;
+[%%expect{|
+val test : 'a t -> 'a = <fun>
+|}];;
+
 let test : type a. a t -> _ = fun x ->
   let r = match x with Int -> 1       (* ok! *)
   in r
 ;;
+[%%expect{|
+val test : 'a t -> int = <fun>
+|}];;
+
 let test : type a. a t -> a = fun x ->
   let r : a = match x with Int -> 1
   in r (* ok *)
 ;;
+[%%expect{|
+val test : 'a t -> 'a = <fun>
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let r = ref None in
   begin match x with Int -> r := Some (1 : a) end;
   !r (* ok *)
 ;;
+[%%expect{|
+val test2 : 'a t -> 'a option = <fun>
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let r : a option ref = ref None in
   begin match x with Int -> r := Some 1 end;
   !r (* ok *)
 ;;
+[%%expect{|
+val test2 : 'a t -> 'a option = <fun>
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let r : a option ref = ref None in
   let u = ref None in
   begin match x with Int -> r := Some 1; u := !r end;
   !u
 ;; (* ok (u non-ambiguous) *)
+[%%expect{|
+val test2 : 'a t -> 'a option = <fun>
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let r : a option ref = ref None in
   let u = ref None in
   begin match x with Int -> u := Some 1; r := !u end;
   !u
 ;; (* fails because u : (int | a) option ref *)
+[%%expect{|
+Line _, characters 46-48:
+Error: This expression has type int option
+       but an expression was expected of type a option
+       Type int is not compatible with type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let u = ref None in
   let r : a option ref = ref None in
   begin match x with Int -> r := Some 1; u := !r end;
   !u
 ;; (* ok *)
+[%%expect{|
+val test2 : 'a t -> 'a option = <fun>
+|}];;
+
 let test2 : type a. a t -> a option = fun x ->
   let u = ref None in
   let a =
@@ -293,10 +527,22 @@ let test2 : type a. a t -> a option = fun x ->
     !u
   in a
 ;; (* ok *)
+[%%expect{|
+val test2 : 'a t -> 'a option = <fun>
+|}];;
+
 let either = ky
 let we_y1x (type a) (x : a) (v : a t) =
   match v with Int -> let y = either 1 x in y
 ;; (* fail *)
+[%%expect{|
+val either : 'a -> 'a -> 'a = <fun>
+Line _, characters 44-45:
+Error: This expression has type a = int
+       but an expression was expected of type 'a
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 (* Effect of external consraints *)
 let f (type a) (x : a t) y =
@@ -304,24 +550,43 @@ let f (type a) (x : a t) y =
   let r = match x with Int -> (y : a) in (* ok *)
   r
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = <fun>
+|}];;
+
 let f (type a) (x : a t) y =
   let r = match x with Int -> (y : a) in
   ignore (y : a); (* ok *)
   r
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = <fun>
+|}];;
+
 let f (type a) (x : a t) y =
   ignore (y : a);
   let r = match x with Int -> y in (* ok *)
   r
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = <fun>
+|}];;
+
 let f (type a) (x : a t) y =
   let r = match x with Int -> y in
   ignore (y : a); (* ok *)
   r
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = <fun>
+|}];;
+
 let f (type a) (x : a t) (y : a) =
   match x with Int -> y (* returns 'a *)
 ;;
+[%%expect{|
+val f : 'a t -> 'a -> 'a = <fun>
+|}];;
 
 (* Combination with local modules *)
 
@@ -330,12 +595,22 @@ let f (type a) (x : a t) y =
     let module M = struct type b = a let z = (y : b) end
     in M.z
 ;; (* fails because of aliasing... *)
+[%%expect{|
+Line _, characters 46-47:
+Error: This expression has type a = int
+       but an expression was expected of type b = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f (type a) (x : a t) y =
   match x with Int ->
     let module M = struct type b = int let z = (y : b) end
     in M.z
 ;; (* ok *)
+[%%expect{|
+val f : 'a t -> int -> int = <fun>
+|}];;
 
 (* Objects and variants *)
 
@@ -347,6 +622,11 @@ let f : type a. a h -> a = function
   | Has_m -> object method m = 1 end
   | Has_b -> object method b = true end
 ;;
+[%%expect{|
+type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
+val f : 'a h -> 'a = <fun>
+|}];;
+
 type _ j =
   | Has_A : [`A of int] j
   | Has_B : [`B of bool] j
@@ -355,23 +635,52 @@ let f : type a. a j -> a = function
   | Has_A -> `A 1
   | Has_B -> `B true
 ;;
+[%%expect{|
+type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
+val f : 'a j -> 'a = <fun>
+|}];;
 
 type (_,_) eq = Eq : ('a,'a) eq ;;
 
 let f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
   fun Eq o -> o
 ;; (* fail *)
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq
+Line _, characters 4-90:
+Error: The universal type variable 'b cannot be generalized:
+       it is already bound to another variable.
+|}];;
 
 let f : type a b. (a,b) eq -> <m : a; ..> -> <m : b; ..> =
   fun Eq o -> o
 ;; (* fail *)
+[%%expect{|
+Line _, characters 14-15:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f (type a) (type b) (eq : (a,b) eq) (o : <m : a; ..>) : <m : b; ..> =
   match eq with Eq -> o ;; (* should fail *)
+[%%expect{|
+Line _, characters 22-23:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> <m : a> -> <m : b> =
   fun Eq o -> o
 ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
+|}];;
 
 let int_of_bool : (bool,int) eq = Obj.magic Eq;;
 
@@ -381,46 +690,116 @@ let y = (x, f int_of_bool x);;
 let f : type a. (a, int) eq -> <m : a> -> bool =
   fun Eq o -> ignore (o : <m : int; ..>); o#m = 3
 ;; (* should be ok *)
+[%%expect{|
+val int_of_bool : (bool, int) eq = Eq
+val x : < m : bool > = <obj>
+val y : < m : bool > * < m : int > = (<obj>, <obj>)
+val f : ('a, int) eq -> < m : 'a > -> bool = <fun>
+|}];;
 
 let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
   fun eq o ->
     ignore (o : < m : a >);
     let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
     r;;
+[%%expect{|
+val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
+|}, Principal{|
+Line _, characters 44-45:
+Error: This expression has type < m : a >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
   fun eq o ->
     let r : < m : b > = match eq with Eq -> o in (* fail *)
     ignore (o : < m : a >);
     r;;
+[%%expect{|
+Line _, characters 44-45:
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> [> `A of a] -> [> `A of b] =
   fun Eq o -> o ;; (* fail *)
+[%%expect{|
+Line _, characters 14-15:
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f (type a b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] =
   match eq with Eq -> v ;; (* should fail *)
+[%%expect{|
+Line _, characters 22-23:
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
   fun Eq o -> o ;; (* fail *)
+[%%expect{|
+Line _, characters 4-84:
+Error: This definition has type
+         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
+       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
+|}];;
 
 let f : type a b. (a,b) eq -> [`A of a | `B] -> [`A of b | `B] =
   fun Eq o -> o ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
+|}];;
 
 let f : type a. (a, int) eq -> [`A of a] -> bool =
   fun Eq v -> match v with `A 1 -> true | _ -> false
 ;; (* ok *)
+[%%expect{|
+val f : ('a, int) eq -> [ `A of 'a ] -> bool = <fun>
+|}];;
 
 let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
   fun eq o ->
     ignore (o : [< `A of a | `B]);
     let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
     r;;
+[%%expect{|
+val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
+|}, Principal{|
+Line _, characters 49-50:
+Error: This expression has type [ `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
   fun eq o ->
     let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
     ignore (o : [< `A of a | `B]);
     r;;
+[%%expect{|
+Line _, characters 49-50:
+Error: This expression has type [> `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+|}];;
 
 (* Pattern matching *)
 
@@ -448,6 +827,16 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | TC, D z -> truncate z
   | _, D _ -> 0
 ;;
+[%%expect{|
+type 'a t = A of int | B of bool | C of float | D of 'a
+type _ ty =
+    TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+val f : 'a ty -> 'a t -> int = <fun>
+|}];;
 
 let f : type a. a ty -> a t -> int = fun x y ->
   match x, y with
@@ -458,6 +847,13 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | TA, D 0 -> -1
   | TA, D z -> z
 ;; (* warn *)
+[%%expect{|
+Line _, characters 2-153:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(TE TC, D [| 0. |])
+val f : 'a ty -> 'a t -> int = <fun>
+|}];;
 
 let f : type a. a ty -> a t -> int = fun x y ->
   match y, x with
@@ -468,6 +864,11 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | D 0, TA -> -1
   | D z, TA -> z
 ;; (* fail *)
+[%%expect{|
+Line _, characters 6-13:
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+|}];;
 
 type ('a,'b) pair = {right:'a; left:'b}
 
@@ -480,6 +881,12 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | {left=TA; right=D 0} -> -1
   | {left=TA; right=D z} -> z
 ;; (* fail *)
+[%%expect{|
+type ('a, 'b) pair = { right : 'a; left : 'b; }
+Line _, characters 25-32:
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+|}];;
 
 type ('a,'b) pair = {left:'a; right:'b}
 
@@ -492,6 +899,14 @@ let f : type a. a ty -> a t -> int = fun x y ->
   | {left=TA; right=D 0} -> -1
   | {left=TA; right=D z} -> z
 ;; (* ok *)
+[%%expect{|
+type ('a, 'b) pair = { left : 'a; right : 'b; }
+Line _, characters 2-244:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=TE TC; right=D [| 0. |]}
+val f : 'a ty -> 'a t -> int = <fun>
+|}];;
 
 (* Injectivity *)
 
@@ -502,14 +917,27 @@ module M : sig type 'a t val eq : ('a t, 'b t) eq end =
 let f : type a b. (a M.t, b M.t) eq -> (a, b) eq =
   function Eq -> Eq (* fail *)
 ;;
+[%%expect{|
+module M : sig type 'a t val eq : ('a t, 'b t) eq end
+Line _, characters 17-19:
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, b) eq
+       Type a is not compatible with type b
+|}];;
 
 let f : type a b. (a M.t * a, b M.t * b) eq -> (a, b) eq =
   function Eq -> Eq (* ok *)
 ;;
+[%%expect{|
+val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun>
+|}];;
 
 let f : type a b. (a * a M.t, b * b M.t) eq -> (a, b) eq =
   function Eq -> Eq (* ok *)
 ;;
+[%%expect{|
+val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun>
+|}];;
 
 (* Applications of polymorphic variants *)
 
@@ -523,6 +951,11 @@ let f : type a. a t -> a = function
 ;;
 
 f V1;;
+[%%expect{|
+type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
+val f : 'a t -> 'a = <fun>
+- : [ `A | `B ] = `A
+|}];;
 
 (* PR#5425 and PR#5427 *)
 
@@ -537,26 +970,54 @@ let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
   let IF_constr, IB_constr = e, e' in
   (x:<foo:int>)
 ;;
+[%%expect{|
+type _ int_foo = IF_constr : < foo : int; .. > int_foo
+type _ int_bar = IB_constr : < bar : int; .. > int_bar
+Line _, characters 3-4:
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < foo : int >
+       Type $0 = < bar : int; .. > is not compatible with type <  >
+       The second object type has no method bar
+|}];;
 
 let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
   let IF_constr, IB_constr = e, e' in
   (x:<foo:int;bar:int>)
 ;;
+[%%expect{|
+Line _, characters 3-4:
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < bar : int; foo : int >
+       Type $0 = < bar : int; .. > is not compatible with type < bar : int >
+       The first object type has an abstract row, it cannot be closed
+|}];;
 
 let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
   let IF_constr, IB_constr = e, e' in
   (x:<foo:int;bar:int;..>)
 ;;
+[%%expect{|
+Line _, characters 2-26:
+Error: This expression has type < bar : int; foo : int; .. >
+       but an expression was expected of type 'a
+       The type constructor $1 would escape its scope
+|}];;
 
 let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) : t =
   let IF_constr, IB_constr = e, e' in
   (x:<foo:int;bar:int;..>)
 ;;
+[%%expect{|
+val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun>
+|}];;
 
 let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
   let IF_constr, IB_constr = e, e' in
   x, x#foo, x#bar
 ;;
+[%%expect{|
+val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun>
+|}];;
 
 (* PR#5554 *)
 
@@ -568,12 +1029,22 @@ let f : type a. a ty -> a =
 let g : type a. a ty -> a =
   let () = () in
   fun x -> match x with Int y -> y;;
+[%%expect{|
+type 'a ty = Int : int -> int ty
+val f : 'a ty -> 'a = <fun>
+val g : 'a ty -> 'a = <fun>
+|}];;
 
 (* Printing of anonymous variables *)
 
 module M = struct type _ t = int end;;
 module M = struct type _ t = T : int t end;;
 module N = M;;
+[%%expect{|
+module M : sig type _ t = int end
+module M : sig type _ t = T : int t end
+module N = M
+|}];;
 
 (* Principality *)
 
@@ -585,6 +1056,9 @@ let f : type a b. (a,b) eq -> (a,int) eq -> a -> b -> _ = fun ab aint a b ->
     if true then a else b
   in ignore x
 ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun>
+|}];;
 
 let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b ->
   let Eq = ab in
@@ -593,3 +1067,6 @@ let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b ->
     if true then a else b
   in ignore x
 ;; (* ok *)
+[%%expect{|
+val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun>
+|}];;

diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference
deleted file mode 100644 (file)
index b69bb6b..0000000
--- a/testsuite/tests/typing-gadts/test.ml.principal.reference
+++ /dev/null
@@ -1,379 +0,0 @@
-
-#                                                         module Exp :
-  sig
-    type _ t =
-        IntLit : int -> int t
-      | BoolLit : bool -> bool t
-      | Pair : 'a t * 'b t -> ('a * 'b) t
-      | App : ('a -> 'b) t * 'a t -> 'b t
-      | Abs : ('a -> 'b) -> ('a -> 'b) t
-    val eval : 's t -> 's
-    val discern : 'a t -> int
-  end
-#                                     module List :
-  sig
-    type zero
-    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
-    val head : ('a * 'b) t -> 'a
-    val tail : ('a * 'b) t -> 'b t
-    val length : 'a t -> int
-  end
-#                                                         Characters 196-224:
-  ......function
-          | C2 x -> x
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-C1 _
-Characters 458-529:
-  ......function
-          | Foo _ , Foo _ -> true
-          | Bar _, Bar _ -> true
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(Bar _, Foo _)
-module Nonexhaustive :
-  sig
-    type 'a u = C1 : int -> int u | C2 : bool -> bool u
-    type 'a v = C1 : int -> int v
-    val unexhaustive : 's u -> 's
-    module M : sig type t type u end
-    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
-    val same_type : 's t * 's t -> bool
-  end
-#                             module Exhaustive :
-  sig
-    type t = int
-    type u = bool
-    type 'a v = Foo : t -> t v | Bar : u -> u v
-    val same_type : 's v * 's v -> bool
-  end
-#           Characters 34-42:
-    class c (Some x) = object method x : int = x end
-            ^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-None
-Characters 139-147:
-    class d (Just x) = object method x : int = x end
-            ^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Nothing
-module PR6862 :
-  sig
-    class c : int option -> object method x : int end
-    type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
-    class d : int opt -> object method x : int end
-  end
-#         module Exhaustive2 :
-  sig type _ t = Int : int t val f : bool t option -> unit end
-#           Characters 146-147:
-    let g : int t -> int = function I -> 1 | _ -> 2 (* no warning *)
-                                             ^
-Warning 56: this match case is unreachable.
-Consider replacing it with a refutation case '<pat> -> .'
-module PR6220 :
-  sig
-    type 'a t = I : int t | F : float t
-    val f : int t -> int
-    val g : int t -> int
-  end
-#                 module PR6403 :
-  sig
-    type (_, _) eq = Refl : ('a, 'a) eq
-    type empty = { bottom : 'a. 'a; }
-    type ('a, 'b) sum = Left of 'a | Right of 'b
-    val notequal : ((int, bool) eq, empty) sum -> empty
-  end
-#                               module PR6437 :
-  sig
-    type ('a, 'b) ctx =
-        Nil : (unit, unit) ctx
-      | Cons : ('a, 'b) ctx -> ('a * unit, 'b * unit) ctx
-    type 'a var = O : ('a * unit) var | S : 'a var -> ('a * unit) var
-    val f : ('g1, 'g2) ctx * 'g1 var -> 'g2 var
-  end
-#                     Characters 175-221:
-  ....match x with
-      | String s -> print_endline s.................
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Any
-module PR6801 :
-  sig
-    type _ value =
-        String : string -> string value
-      | Float : float -> float value
-      | Any
-    val print_string_value : string value -> unit
-  end
-#               Characters 118-119:
-      let eval (D x) = x
-                       ^
-Error: This expression has type $D_'a t
-       but an expression was expected of type 'a
-       The type constructor $D_'a would escape its scope
-#               module Rectype :
-  sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end
-#                         Characters 180-188:
-          | (IntLit _ | BoolLit _) -> ()
-             ^^^^^^^^
-Error: This pattern matches values of type int t
-       but a pattern was expected which matches values of type s t
-       Type int is not compatible with type s 
-#                         module Polymorphic_variants :
-  sig
-    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-    val eval : [ `A ] * 's t -> unit
-  end
-#                                 Characters 299-300:
-      | BoolLit b -> b
-                     ^
-Error: This expression has type bool but an expression was expected of type s
-#             Characters 87-88:
-    let f = function A -> 1 | B -> 2
-                              ^
-Error: This pattern matches values of type b
-       but a pattern was expected which matches values of type a
-#             Characters 89-92:
-        Foo -> 5
-        ^^^
-Error: This pattern matches values of type 'a t
-       but a pattern was expected which matches values of type int
-#   type _ t = Int : int t
-#   val ky : 'a -> 'a -> 'a = <fun>
-#       val test : 'a t -> 'a = <fun>
-#       val test : 'a t -> int = <fun>
-#       Characters 49-61:
-    function Int -> ky (1 : a) 1  (* fails *)
-                    ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#         Characters 70-82:
-    let r = match x with Int -> ky (1 : a) 1  (* fails *)
-                                ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#       Characters 69-81:
-    let r = match x with Int -> ky 1 (1 : a)  (* fails *)
-                                ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#       val test : 'a t -> int = <fun>
-#       val test : 'a t -> 'a = <fun>
-#       val test : 'a t -> int = <fun>
-#       val test : 'a t -> 'a = <fun>
-#         val test2 : 'a t -> 'a option = <fun>
-#         val test2 : 'a t -> 'a option = <fun>
-#           val test2 : 'a t -> 'a option = <fun>
-#           Characters 152-154:
-    begin match x with Int -> u := Some 1; r := !u end;
-                                                ^^
-Error: This expression has type int option
-       but an expression was expected of type a option
-       Type int is not compatible with type a = int 
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#           val test2 : 'a t -> 'a option = <fun>
-#               val test2 : 'a t -> 'a option = <fun>
-#       Characters 100-101:
-    match v with Int -> let y = either 1 x in y
-                                              ^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#             val f : 'a t -> 'a -> 'a = <fun>
-#         val f : 'a t -> 'a -> 'a = <fun>
-#         val f : 'a t -> 'a -> 'a = <fun>
-#         val f : 'a t -> 'a -> 'a = <fun>
-#     val f : 'a t -> 'a -> 'a = <fun>
-#               Characters 136-137:
-      let module M = struct type b = a let z = (y : b) end
-                                                ^
-Error: This expression has type a = int
-       but an expression was expected of type b = int
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#           val f : 'a t -> int -> int = <fun>
-#                     type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
-val f : 'a h -> 'a = <fun>
-#               type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
-val f : 'a j -> 'a = <fun>
-#   type (_, _) eq = Eq : ('a, 'a) eq
-#       Characters 5-91:
-  ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
-    fun Eq o -> o
-Error: The universal type variable 'b cannot be generalized:
-       it is already bound to another variable.
-#       Characters 74-75:
-    fun Eq o -> o
-                ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b; .. >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 97-98:
-    match eq with Eq -> o ;; (* should fail *)
-                        ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b; .. >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#       val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
-#   val int_of_bool : (bool, int) eq = Eq
-#   val x : < m : bool > = <obj>
-# val y : < m : bool > * < m : int > = (<obj>, <obj>)
-#       val f : ('a, int) eq -> < m : 'a > -> bool = <fun>
-#           Characters 146-147:
-      let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
-                                              ^
-Error: This expression has type < m : a >
-       but an expression was expected of type < m : b >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#           Characters 118-119:
-      let r : < m : b > = match eq with Eq -> o in (* fail *)
-                                              ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 74-75:
-    fun Eq o -> o ;; (* fail *)
-                ^
-Error: This expression has type [> `A of a ]
-       but an expression was expected of type [> `A of b ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 90-91:
-    match eq with Eq -> v ;; (* should fail *)
-                        ^
-Error: This expression has type [> `A of a ]
-       but an expression was expected of type [> `A of b ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 5-85:
-  ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
-    fun Eq o -> o..............
-Error: This definition has type
-         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
-       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
-#     val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
-#       val f : ('a, int) eq -> [ `A of 'a ] -> bool = <fun>
-#           Characters 166-167:
-      let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
-                                                   ^
-Error: This expression has type [ `A of a | `B ]
-       but an expression was expected of type [ `A of b | `B ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#           Characters 131-132:
-      let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
-                                                   ^
-Error: This expression has type [> `A of a | `B ]
-       but an expression was expected of type [ `A of b | `B ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#                                                     type 'a t = A of int | B of bool | C of float | D of 'a
-type _ ty =
-    TE : 'a ty -> 'a array ty
-  | TA : int ty
-  | TB : bool ty
-  | TC : float ty
-  | TD : string -> bool ty
-val f : 'a ty -> 'a t -> int = <fun>
-#                   Characters 51-202:
-  ..match x, y with
-    | _, A z -> z
-    | _, B z -> if z then 1 else 2
-    | _, C z -> truncate z
-    | TE TC, D [|1.0|] -> 14
-    | TA, D 0 -> -1
-    | TA, D z -> z
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(TE TC, D [| 0. |])
-val f : 'a ty -> 'a t -> int = <fun>
-#                   Characters 147-154:
-    | D [|1.0|], TE TC -> 14
-        ^^^^^^^
-Error: This pattern matches values of type 'a array
-       but a pattern was expected which matches values of type a
-#                       Characters 259-266:
-    | {left=TE TC; right=D [|1.0|]} -> 14
-                           ^^^^^^^
-Error: This pattern matches values of type 'a array
-       but a pattern was expected which matches values of type a
-#                       Characters 92-334:
-  ..match {left=x; right=y} with
-    | {left=_; right=A z} -> z
-    | {left=_; right=B z} -> if z then 1 else 2
-    | {left=_; right=C z} -> truncate z
-    | {left=TE TC; right=D [|1.0|]} -> 14
-    | {left=TA; right=D 0} -> -1
-    | {left=TA; right=D z} -> z
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-{left=TE TC; right=D [| 0. |]}
-type ('a, 'b) pair = { left : 'a; right : 'b; }
-val f : 'a ty -> 'a t -> int = <fun>
-#           module M : sig type 'a t val eq : ('a t, 'b t) eq end
-#       Characters 69-71:
-    function Eq -> Eq (* fail *)
-                   ^^
-Error: This expression has type (a, a) eq
-       but an expression was expected of type (a, b) eq
-       Type a is not compatible with type b 
-#       val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun>
-#       val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun>
-#                     type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
-val f : 'a t -> 'a = <fun>
-#   - : [ `A | `B ] = `A
-#                 type _ int_foo = IF_constr : < foo : int; .. > int_foo
-type _ int_bar = IB_constr : < bar : int; .. > int_bar
-#         Characters 98-99:
-    (x:<foo:int>)
-     ^
-Error: This expression has type t = < foo : int; .. >
-       but an expression was expected of type < foo : int >
-       Type $0 = < bar : int; .. > is not compatible with type <  > 
-       The second object type has no method bar
-#         Characters 98-99:
-    (x:<foo:int;bar:int>)
-     ^
-Error: This expression has type t = < foo : int; .. >
-       but an expression was expected of type < bar : int; foo : int >
-       Type $0 = < bar : int; .. > is not compatible with type < bar : int > 
-       The first object type has an abstract row, it cannot be closed
-#         Characters 97-121:
-    (x:<foo:int;bar:int;..>)
-    ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type < bar : int; foo : int; .. >
-       but an expression was expected of type 'a
-       The type constructor $1 would escape its scope
-#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun>
-#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun>
-#       type 'a ty = Int : int -> int ty
-#     val f : 'a ty -> 'a = <fun>
-#       val g : 'a ty -> 'a = <fun>
-#       module M : sig type _ t = int end
-# module M : sig type _ t = T : int t end
-# module N = M
-#                     val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun>
-#               val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference
deleted file mode 100644 (file)
index 2ef3715..0000000
--- a/testsuite/tests/typing-gadts/test.ml.reference
+++ /dev/null
@@ -1,366 +0,0 @@
-
-#                                                         module Exp :
-  sig
-    type _ t =
-        IntLit : int -> int t
-      | BoolLit : bool -> bool t
-      | Pair : 'a t * 'b t -> ('a * 'b) t
-      | App : ('a -> 'b) t * 'a t -> 'b t
-      | Abs : ('a -> 'b) -> ('a -> 'b) t
-    val eval : 's t -> 's
-    val discern : 'a t -> int
-  end
-#                                     module List :
-  sig
-    type zero
-    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
-    val head : ('a * 'b) t -> 'a
-    val tail : ('a * 'b) t -> 'b t
-    val length : 'a t -> int
-  end
-#                                                         Characters 196-224:
-  ......function
-          | C2 x -> x
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-C1 _
-Characters 458-529:
-  ......function
-          | Foo _ , Foo _ -> true
-          | Bar _, Bar _ -> true
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(Bar _, Foo _)
-module Nonexhaustive :
-  sig
-    type 'a u = C1 : int -> int u | C2 : bool -> bool u
-    type 'a v = C1 : int -> int v
-    val unexhaustive : 's u -> 's
-    module M : sig type t type u end
-    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
-    val same_type : 's t * 's t -> bool
-  end
-#                             module Exhaustive :
-  sig
-    type t = int
-    type u = bool
-    type 'a v = Foo : t -> t v | Bar : u -> u v
-    val same_type : 's v * 's v -> bool
-  end
-#           Characters 34-42:
-    class c (Some x) = object method x : int = x end
-            ^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-None
-Characters 139-147:
-    class d (Just x) = object method x : int = x end
-            ^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Nothing
-module PR6862 :
-  sig
-    class c : int option -> object method x : int end
-    type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt
-    class d : int opt -> object method x : int end
-  end
-#         module Exhaustive2 :
-  sig type _ t = Int : int t val f : bool t option -> unit end
-#           Characters 146-147:
-    let g : int t -> int = function I -> 1 | _ -> 2 (* no warning *)
-                                             ^
-Warning 56: this match case is unreachable.
-Consider replacing it with a refutation case '<pat> -> .'
-module PR6220 :
-  sig
-    type 'a t = I : int t | F : float t
-    val f : int t -> int
-    val g : int t -> int
-  end
-#                 module PR6403 :
-  sig
-    type (_, _) eq = Refl : ('a, 'a) eq
-    type empty = { bottom : 'a. 'a; }
-    type ('a, 'b) sum = Left of 'a | Right of 'b
-    val notequal : ((int, bool) eq, empty) sum -> empty
-  end
-#                               module PR6437 :
-  sig
-    type ('a, 'b) ctx =
-        Nil : (unit, unit) ctx
-      | Cons : ('a, 'b) ctx -> ('a * unit, 'b * unit) ctx
-    type 'a var = O : ('a * unit) var | S : 'a var -> ('a * unit) var
-    val f : ('g1, 'g2) ctx * 'g1 var -> 'g2 var
-  end
-#                     Characters 175-221:
-  ....match x with
-      | String s -> print_endline s.................
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-Any
-module PR6801 :
-  sig
-    type _ value =
-        String : string -> string value
-      | Float : float -> float value
-      | Any
-    val print_string_value : string value -> unit
-  end
-#               Characters 118-119:
-      let eval (D x) = x
-                       ^
-Error: This expression has type $D_'a t
-       but an expression was expected of type 'a
-       The type constructor $D_'a would escape its scope
-#               module Rectype :
-  sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end
-#                         Characters 180-188:
-          | (IntLit _ | BoolLit _) -> ()
-             ^^^^^^^^
-Error: This pattern matches values of type int t
-       but a pattern was expected which matches values of type s t
-       Type int is not compatible with type s 
-#                         module Polymorphic_variants :
-  sig
-    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-    val eval : [ `A ] * 's t -> unit
-  end
-#                                 module Propagation :
-  sig
-    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
-    val check : 's t -> 's
-  end
-#             Characters 87-88:
-    let f = function A -> 1 | B -> 2
-                              ^
-Error: This variant pattern is expected to have type a
-       The constructor B does not belong to type a
-#             Characters 89-92:
-        Foo -> 5
-        ^^^
-Error: This pattern matches values of type 'a t
-       but a pattern was expected which matches values of type int
-#   type _ t = Int : int t
-#   val ky : 'a -> 'a -> 'a = <fun>
-#       val test : 'a t -> 'a = <fun>
-#       val test : 'a t -> int = <fun>
-#       Characters 49-61:
-    function Int -> ky (1 : a) 1  (* fails *)
-                    ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#         Characters 70-82:
-    let r = match x with Int -> ky (1 : a) 1  (* fails *)
-                                ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#       Characters 69-81:
-    let r = match x with Int -> ky 1 (1 : a)  (* fails *)
-                                ^^^^^^^^^^^^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#       val test : 'a t -> int = <fun>
-#       val test : 'a t -> 'a = <fun>
-#       val test : 'a t -> int = <fun>
-#       val test : 'a t -> 'a = <fun>
-#         val test2 : 'a t -> 'a option = <fun>
-#         val test2 : 'a t -> 'a option = <fun>
-#           val test2 : 'a t -> 'a option = <fun>
-#           Characters 152-154:
-    begin match x with Int -> u := Some 1; r := !u end;
-                                                ^^
-Error: This expression has type int option
-       but an expression was expected of type a option
-       Type int is not compatible with type a = int 
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#           val test2 : 'a t -> 'a option = <fun>
-#               val test2 : 'a t -> 'a option = <fun>
-#       Characters 100-101:
-    match v with Int -> let y = either 1 x in y
-                                              ^
-Error: This expression has type a = int
-       but an expression was expected of type 'a
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#             val f : 'a t -> 'a -> 'a = <fun>
-#         val f : 'a t -> 'a -> 'a = <fun>
-#         val f : 'a t -> 'a -> 'a = <fun>
-#         val f : 'a t -> 'a -> 'a = <fun>
-#     val f : 'a t -> 'a -> 'a = <fun>
-#               Characters 136-137:
-      let module M = struct type b = a let z = (y : b) end
-                                                ^
-Error: This expression has type a = int
-       but an expression was expected of type b = int
-       This instance of int is ambiguous:
-       it would escape the scope of its equation
-#           val f : 'a t -> int -> int = <fun>
-#                     type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
-val f : 'a h -> 'a = <fun>
-#               type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
-val f : 'a j -> 'a = <fun>
-#   type (_, _) eq = Eq : ('a, 'a) eq
-#       Characters 5-91:
-  ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
-    fun Eq o -> o
-Error: The universal type variable 'b cannot be generalized:
-       it is already bound to another variable.
-#       Characters 74-75:
-    fun Eq o -> o
-                ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b; .. >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 97-98:
-    match eq with Eq -> o ;; (* should fail *)
-                        ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b; .. >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#       val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
-#   val int_of_bool : (bool, int) eq = Eq
-#   val x : < m : bool > = <obj>
-# val y : < m : bool > * < m : int > = (<obj>, <obj>)
-#       val f : ('a, int) eq -> < m : 'a > -> bool = <fun>
-#           val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
-#           Characters 118-119:
-      let r : < m : b > = match eq with Eq -> o in (* fail *)
-                                              ^
-Error: This expression has type < m : a; .. >
-       but an expression was expected of type < m : b >
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 74-75:
-    fun Eq o -> o ;; (* fail *)
-                ^
-Error: This expression has type [> `A of a ]
-       but an expression was expected of type [> `A of b ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 90-91:
-    match eq with Eq -> v ;; (* should fail *)
-                        ^
-Error: This expression has type [> `A of a ]
-       but an expression was expected of type [> `A of b ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#     Characters 5-85:
-  ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
-    fun Eq o -> o..............
-Error: This definition has type
-         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
-       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
-#     val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
-#       val f : ('a, int) eq -> [ `A of 'a ] -> bool = <fun>
-#           val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
-#           Characters 131-132:
-      let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
-                                                   ^
-Error: This expression has type [> `A of a | `B ]
-       but an expression was expected of type [ `A of b | `B ]
-       Type a is not compatible with type b = a 
-       This instance of a is ambiguous:
-       it would escape the scope of its equation
-#                                                     type 'a t = A of int | B of bool | C of float | D of 'a
-type _ ty =
-    TE : 'a ty -> 'a array ty
-  | TA : int ty
-  | TB : bool ty
-  | TC : float ty
-  | TD : string -> bool ty
-val f : 'a ty -> 'a t -> int = <fun>
-#                   Characters 51-202:
-  ..match x, y with
-    | _, A z -> z
-    | _, B z -> if z then 1 else 2
-    | _, C z -> truncate z
-    | TE TC, D [|1.0|] -> 14
-    | TA, D 0 -> -1
-    | TA, D z -> z
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(TE TC, D [| 0. |])
-val f : 'a ty -> 'a t -> int = <fun>
-#                   Characters 147-154:
-    | D [|1.0|], TE TC -> 14
-        ^^^^^^^
-Error: This pattern matches values of type 'a array
-       but a pattern was expected which matches values of type a
-#                       Characters 259-266:
-    | {left=TE TC; right=D [|1.0|]} -> 14
-                           ^^^^^^^
-Error: This pattern matches values of type 'a array
-       but a pattern was expected which matches values of type a
-#                       Characters 92-334:
-  ..match {left=x; right=y} with
-    | {left=_; right=A z} -> z
-    | {left=_; right=B z} -> if z then 1 else 2
-    | {left=_; right=C z} -> truncate z
-    | {left=TE TC; right=D [|1.0|]} -> 14
-    | {left=TA; right=D 0} -> -1
-    | {left=TA; right=D z} -> z
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-{left=TE TC; right=D [| 0. |]}
-type ('a, 'b) pair = { left : 'a; right : 'b; }
-val f : 'a ty -> 'a t -> int = <fun>
-#           module M : sig type 'a t val eq : ('a t, 'b t) eq end
-#       Characters 69-71:
-    function Eq -> Eq (* fail *)
-                   ^^
-Error: This expression has type (a, a) eq
-       but an expression was expected of type (a, b) eq
-       Type a is not compatible with type b 
-#       val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun>
-#       val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun>
-#                     type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
-val f : 'a t -> 'a = <fun>
-#   - : [ `A | `B ] = `A
-#                 type _ int_foo = IF_constr : < foo : int; .. > int_foo
-type _ int_bar = IB_constr : < bar : int; .. > int_bar
-#         Characters 98-99:
-    (x:<foo:int>)
-     ^
-Error: This expression has type t = < foo : int; .. >
-       but an expression was expected of type < foo : int >
-       Type $0 = < bar : int; .. > is not compatible with type <  > 
-       The second object type has no method bar
-#         Characters 98-99:
-    (x:<foo:int;bar:int>)
-     ^
-Error: This expression has type t = < foo : int; .. >
-       but an expression was expected of type < bar : int; foo : int >
-       Type $0 = < bar : int; .. > is not compatible with type < bar : int > 
-       The first object type has an abstract row, it cannot be closed
-#         Characters 97-121:
-    (x:<foo:int;bar:int;..>)
-    ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type < bar : int; foo : int; .. >
-       but an expression was expected of type 'a
-       The type constructor $1 would escape its scope
-#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun>
-#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun>
-#       type 'a ty = Int : int -> int ty
-#     val f : 'a ty -> 'a = <fun>
-#       val g : 'a ty -> 'a = <fun>
-#       module M : sig type _ t = int end
-# module M : sig type _ t = T : int t end
-# module N = M
-#                     val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun>
-#               val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/unify_mb.ml b/testsuite/tests/typing-gadts/unify_mb.ml
index 89f69211881c5527808d670ed703a7b91a4d06d0..f11f92cc1f37c9a5a4ea829860eb8de77d58a0c9 100644 (file)
--- a/testsuite/tests/typing-gadts/unify_mb.ml
+++ b/testsuite/tests/typing-gadts/unify_mb.ml
@@ -29,6 +29,14 @@ let fin_succ : type n. n fin -> n is_succ = function
   | FZ -> IS
   | FS _ -> IS
 ;;
+[%%expect{|
+type zero = Zero
+type _ succ = Succ
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+type _ fin = FZ : 'a succ fin | FS : 'a fin -> 'a succ fin
+type _ is_succ = IS : 'a succ is_succ
+val fin_succ : 'n fin -> 'n is_succ = <fun>
+|}];;
 
 (* 3 First-Order Terms, Renaming and Substitution *)
 
@@ -50,6 +58,14 @@ let comp_subst f g (x : 'a fin) = pre_subst f (g x)
 (*  val comp_subst :
     ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term *)
 ;;
+[%%expect{|
+type 'a term = Var of 'a fin | Leaf | Fork of 'a term * 'a term
+val var : 'a fin -> 'a term = <fun>
+val lift : ('m fin -> 'n fin) -> 'm fin -> 'n term = <fun>
+val pre_subst : ('a fin -> 'b term) -> 'a term -> 'b term = <fun>
+val comp_subst :
+  ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term = <fun>
+|}];;
 
 (* 4 The Occur-Check, through thick and thin *)
 
@@ -58,12 +74,18 @@ let rec thin : type n. n succ fin -> n fin -> n succ fin =
   | FZ, y    -> FS y
   | FS x, FZ -> FZ
   | FS x, FS y -> FS (thin x y)
+[%%expect{|
+val thin : 'n succ fin -> 'n fin -> 'n succ fin = <fun>
+|}];;
 
 let bind t f =
   match t with
   | None   -> None
   | Some x -> f x
 (* val bind : 'a option -> ('a -> 'b option) -> 'b option *)
+[%%expect{|
+val bind : 'a option -> ('a -> 'b option) -> 'b option = <fun>
+|}];;
 
 let rec thick : type n. n succ fin -> n succ fin -> n fin option =
   fun x y -> match x, y with
@@ -72,6 +94,9 @@ let rec thick : type n. n succ fin -> n succ fin -> n fin option =
   | FS x, FZ -> let IS = fin_succ x in Some FZ
   | FS x, FS y ->
       let IS = fin_succ x in bind (thick x y) (fun x -> Some (FS x))
+[%%expect{|
+val thick : 'n succ fin -> 'n succ fin -> 'n fin option = <fun>
+|}];;
 
 let rec check : type n. n succ fin -> n succ term -> n term option =
   fun x t -> match t with
@@ -80,16 +105,25 @@ let rec check : type n. n succ fin -> n succ term -> n term option =
   | Fork (t1, t2) ->
       bind (check x t1) (fun t1 ->
         bind (check x t2) (fun t2 -> Some (Fork (t1, t2))))
+[%%expect{|
+val check : 'n succ fin -> 'n succ term -> 'n term option = <fun>
+|}];;
 
 let subst_var x t' y =
   match thick x y with
   | None -> t'
   | Some y' -> Var y'
 (* val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term *)
+[%%expect{|
+val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term = <fun>
+|}];;
 
 let subst x t' = pre_subst (subst_var x t')
 (* val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term *)
 ;;
+[%%expect{|
+val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term = <fun>
+|}];;
 
 (* 5 A Refinement of Substitution *)
 
@@ -100,15 +134,29 @@ type (_,_) alist =
 let rec sub : type m n. (m,n) alist -> m fin -> n term = function
   | Anil -> var
   | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t)
+[%%expect{|
+type (_, _) alist =
+    Anil : ('n, 'n) alist
+  | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
+val sub : ('m, 'n) alist -> 'm fin -> 'n term = <fun>
+|}];;
 
 let rec append : type m n l. (m,n) alist -> (l,m) alist -> (l,n) alist =
   fun r s -> match s with
   | Anil -> r
   | Asnoc (s, t, x) -> Asnoc (append r s, t, x)
+[%%expect{|
+val append : ('m, 'n) alist -> ('l, 'm) alist -> ('l, 'n) alist = <fun>
+|}];;
 
 type _ ealist = EAlist : ('a,'b) alist -> 'a ealist
 
 let asnoc a t' x = EAlist (Asnoc (a, t', x))
+[%%expect{|
+type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist
+val asnoc : ('a, 'b) alist -> 'a term -> 'a succ fin -> 'a succ ealist =
+  <fun>
+|}];;
 
 (* Extra work: we need sub to work on ealist too, for examples *)
 let rec weaken_fin : type n. n fin -> n succ fin = function
@@ -131,6 +179,13 @@ let rec sub' : type m. m ealist -> m fin -> m term = function
 let subst' d = pre_subst (sub' d)
 (*  val subst' : 'a ealist -> 'a term -> 'a term *)
 ;;
+[%%expect{|
+val weaken_fin : 'n fin -> 'n succ fin = <fun>
+val weaken_term : 'a term -> 'a succ term = <fun>
+val weaken_alist : ('m, 'n) alist -> ('m succ, 'n succ) alist = <fun>
+val sub' : 'm ealist -> 'm fin -> 'm term = <fun>
+val subst' : 'a ealist -> 'a term -> 'a term = <fun>
+|}];;
 
 (* 6 First-Order Unification *)
 
@@ -161,6 +216,12 @@ let rec amgu : type m. m term -> m term -> m ealist -> m ealist option =
 let mgu s t = amgu s t (EAlist Anil)
 (* val mgu : 'a term -> 'a term -> 'a ealist option *)
 ;;
+[%%expect{|
+val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist = <fun>
+val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option = <fun>
+val amgu : 'm term -> 'm term -> 'm ealist -> 'm ealist option = <fun>
+val mgu : 'a term -> 'a term -> 'a ealist option = <fun>
+|}];;
 
 let s = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
 let t = Fork (Var (FS FZ), Var (FS FZ))
@@ -168,3 +229,13 @@ let d = match mgu s t with Some x -> x | None -> failwith "mgu"
 let s' = subst' d s
 let t' = subst' d t
 ;;
+[%%expect{|
+val s : 'a succ succ succ term = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
+val t : 'a succ succ term = Fork (Var (FS FZ), Var (FS FZ))
+val d : '_a succ succ succ ealist =
+  EAlist (Asnoc (Asnoc (Anil, Fork (Var FZ, Leaf), FZ), Var FZ, FZ))
+val s' : '_a succ succ succ term =
+  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
+val t' : '_a succ succ succ term =
+  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
+|}];;

diff --git a/testsuite/tests/typing-gadts/unify_mb.ml.principal.reference b/testsuite/tests/typing-gadts/unify_mb.ml.principal.reference
deleted file mode 100644 (file)
index 90e69dc..0000000
--- a/testsuite/tests/typing-gadts/unify_mb.ml.principal.reference
+++ /dev/null
@@ -1,45 +0,0 @@
-
-#                                       * * *                 type zero = Zero
-type _ succ = Succ
-type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
-type _ fin = FZ : 'a succ fin | FS : 'a fin -> 'a succ fin
-type _ is_succ = IS : 'a succ is_succ
-val fin_succ : 'n fin -> 'n is_succ = <fun>
-#                                     *   type 'a term = Var of 'a fin | Leaf | Fork of 'a term * 'a term
-val var : 'a fin -> 'a term = <fun>
-val lift : ('m fin -> 'n fin) -> 'm fin -> 'n term = <fun>
-val pre_subst : ('a fin -> 'b term) -> 'a term -> 'b term = <fun>
-val comp_subst :
-  ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term = <fun>
-#                                                                               val thin : 'n succ fin -> 'n fin -> 'n succ fin = <fun>
-val bind : 'a option -> ('a -> 'b option) -> 'b option = <fun>
-val thick : 'n succ fin -> 'n succ fin -> 'n fin option = <fun>
-val check : 'n succ fin -> 'n succ term -> 'n term option = <fun>
-val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term = <fun>
-val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term = <fun>
-#                                                                                 type (_, _) alist =
-    Anil : ('n, 'n) alist
-  | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
-val sub : ('m, 'n) alist -> 'm fin -> 'n term = <fun>
-val append : ('m, 'n) alist -> ('l, 'm) alist -> ('l, 'n) alist = <fun>
-type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist
-val asnoc : ('a, 'b) alist -> 'a term -> 'a succ fin -> 'a succ ealist =
-  <fun>
-val weaken_fin : 'n fin -> 'n succ fin = <fun>
-val weaken_term : 'a term -> 'a succ term = <fun>
-val weaken_alist : ('m, 'n) alist -> ('m succ, 'n succ) alist = <fun>
-val sub' : 'm ealist -> 'm fin -> 'm term = <fun>
-val subst' : 'a ealist -> 'a term -> 'a term = <fun>
-#                                                           val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist = <fun>
-val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option = <fun>
-val amgu : 'm term -> 'm term -> 'm ealist -> 'm ealist option = <fun>
-val mgu : 'a term -> 'a term -> 'a ealist option = <fun>
-#             val s : 'a succ succ succ term = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
-val t : 'a succ succ term = Fork (Var (FS FZ), Var (FS FZ))
-val d : '_a succ succ succ ealist =
-  EAlist (Asnoc (Asnoc (Anil, Fork (Var FZ, Leaf), FZ), Var FZ, FZ))
-val s' : '_a succ succ succ term =
-  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-val t' : '_a succ succ succ term =
-  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-# 

diff --git a/testsuite/tests/typing-gadts/unify_mb.ml.reference b/testsuite/tests/typing-gadts/unify_mb.ml.reference
deleted file mode 100644 (file)
index 90e69dc..0000000
--- a/testsuite/tests/typing-gadts/unify_mb.ml.reference
+++ /dev/null
@@ -1,45 +0,0 @@
-
-#                                       * * *                 type zero = Zero
-type _ succ = Succ
-type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
-type _ fin = FZ : 'a succ fin | FS : 'a fin -> 'a succ fin
-type _ is_succ = IS : 'a succ is_succ
-val fin_succ : 'n fin -> 'n is_succ = <fun>
-#                                     *   type 'a term = Var of 'a fin | Leaf | Fork of 'a term * 'a term
-val var : 'a fin -> 'a term = <fun>
-val lift : ('m fin -> 'n fin) -> 'm fin -> 'n term = <fun>
-val pre_subst : ('a fin -> 'b term) -> 'a term -> 'b term = <fun>
-val comp_subst :
-  ('b fin -> 'c term) -> ('a fin -> 'b term) -> 'a fin -> 'c term = <fun>
-#                                                                               val thin : 'n succ fin -> 'n fin -> 'n succ fin = <fun>
-val bind : 'a option -> ('a -> 'b option) -> 'b option = <fun>
-val thick : 'n succ fin -> 'n succ fin -> 'n fin option = <fun>
-val check : 'n succ fin -> 'n succ term -> 'n term option = <fun>
-val subst_var : 'a succ fin -> 'a term -> 'a succ fin -> 'a term = <fun>
-val subst : 'a succ fin -> 'a term -> 'a succ term -> 'a term = <fun>
-#                                                                                 type (_, _) alist =
-    Anil : ('n, 'n) alist
-  | Asnoc : ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist
-val sub : ('m, 'n) alist -> 'm fin -> 'n term = <fun>
-val append : ('m, 'n) alist -> ('l, 'm) alist -> ('l, 'n) alist = <fun>
-type _ ealist = EAlist : ('a, 'b) alist -> 'a ealist
-val asnoc : ('a, 'b) alist -> 'a term -> 'a succ fin -> 'a succ ealist =
-  <fun>
-val weaken_fin : 'n fin -> 'n succ fin = <fun>
-val weaken_term : 'a term -> 'a succ term = <fun>
-val weaken_alist : ('m, 'n) alist -> ('m succ, 'n succ) alist = <fun>
-val sub' : 'm ealist -> 'm fin -> 'm term = <fun>
-val subst' : 'a ealist -> 'a term -> 'a term = <fun>
-#                                                           val flex_flex : 'a succ fin -> 'a succ fin -> 'a succ ealist = <fun>
-val flex_rigid : 'a succ fin -> 'a succ term -> 'a succ ealist option = <fun>
-val amgu : 'm term -> 'm term -> 'm ealist -> 'm ealist option = <fun>
-val mgu : 'a term -> 'a term -> 'a ealist option = <fun>
-#             val s : 'a succ succ succ term = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
-val t : 'a succ succ term = Fork (Var (FS FZ), Var (FS FZ))
-val d : '_a succ succ succ ealist =
-  EAlist (Asnoc (Asnoc (Anil, Fork (Var FZ, Leaf), FZ), Var FZ, FZ))
-val s' : '_a succ succ succ term =
-  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-val t' : '_a succ succ succ term =
-  Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-# 

diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml
index 983822bcc857da09a69222d4500336b68d2a8cf3..b4e60e8c80882b3c000f4b2318687e684d71c13d 100644 (file)
--- a/testsuite/tests/typing-gadts/yallop_bugs.ml
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml
@@ -12,6 +12,11 @@ let magic : 'a 'b. 'a -> 'b =
         (struct type 'a t = unit end)
     in M.f Refl
 ;;
+[%%expect{|
+type (_, _) eq = Refl : ('a, 'a) eq
+Line _, characters 44-52:
+Error: Type a is not a subtype of b
+|}];;
 
 (* Variance and subtyping *)
 
@@ -25,6 +30,11 @@ let magic : 'a 'b. 'a -> 'b =
       fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in
     (downcast bad_proof ((object method m = x end) :> < >)) # m
 ;;
+[%%expect{|
+Line _, characters 0-36:
+Error: In this GADT definition, the variance of some parameter
+       cannot be checked
+|}];;
 
 (* Record patterns *)
 
@@ -36,6 +46,14 @@ let check : type s . s t * s -> bool = function
   | BoolLit, false -> false
   | IntLit , 6 -> false
 ;;
+[%%expect{|
+type _ t = IntLit : int t | BoolLit : bool t
+Line _, characters 39-99:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(IntLit, 0)
+val check : 's t * 's -> bool = <fun>
+|}];;
 
 type ('a, 'b) pair = { fst : 'a; snd : 'b }
 
@@ -43,3 +61,11 @@ let check : type s . (s t, s) pair -> bool = function
   | {fst = BoolLit; snd = false} -> false
   | {fst = IntLit ; snd =  6} -> false
 ;;
+[%%expect{|
+type ('a, 'b) pair = { fst : 'a; snd : 'b; }
+Line _, characters 45-134:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{fst=IntLit; snd=0}
+val check : ('s t, 's) pair -> bool = <fun>
+|}];;

diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference
deleted file mode 100644 (file)
index accbebf..0000000
--- a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference
+++ /dev/null
@@ -1,29 +0,0 @@
-
-#                           Characters 233-241:
-           let f (Refl : (a T.t, b T.t) eq) = (x :> b)
-                                              ^^^^^^^^
-Error: Type a is not a subtype of b 
-#                         Characters 31-67:
-  type (_, +_) eq = Refl : ('a, 'a) eq
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this GADT definition, the variance of some parameter
-       cannot be checked
-#                     Characters 115-175:
-  .......................................function
-    | BoolLit, false -> false
-    | IntLit , 6 -> false
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(IntLit, 0)
-type _ t = IntLit : int t | BoolLit : bool t
-val check : 's t * 's -> bool = <fun>
-#             Characters 91-180:
-  .............................................function
-    | {fst = BoolLit; snd = false} -> false
-    | {fst = IntLit ; snd =  6} -> false
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-{fst=IntLit; snd=0}
-type ('a, 'b) pair = { fst : 'a; snd : 'b; }
-val check : ('s t, 's) pair -> bool = <fun>
-# 

diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference
deleted file mode 100644 (file)
index accbebf..0000000
--- a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference
+++ /dev/null
@@ -1,29 +0,0 @@
-
-#                           Characters 233-241:
-           let f (Refl : (a T.t, b T.t) eq) = (x :> b)
-                                              ^^^^^^^^
-Error: Type a is not a subtype of b 
-#                         Characters 31-67:
-  type (_, +_) eq = Refl : ('a, 'a) eq
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In this GADT definition, the variance of some parameter
-       cannot be checked
-#                     Characters 115-175:
-  .......................................function
-    | BoolLit, false -> false
-    | IntLit , 6 -> false
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(IntLit, 0)
-type _ t = IntLit : int t | BoolLit : bool t
-val check : 's t * 's -> bool = <fun>
-#             Characters 91-180:
-  .............................................function
-    | {fst = BoolLit; snd = false} -> false
-    | {fst = IntLit ; snd =  6} -> false
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-{fst=IntLit; snd=0}
-type ('a, 'b) pair = { fst : 'a; snd : 'b; }
-val check : ('s t, 's) pair -> bool = <fun>
-# 

diff --git a/testsuite/tests/typing-immediate/Makefile b/testsuite/tests/typing-immediate/Makefile
index 7fc00661cbe83513fbab37e2fe27d89365c35054..0b15e777de9b37e51d0594072c80e3eef907fd3e 100644 (file)
--- a/testsuite/tests/typing-immediate/Makefile
+++ b/testsuite/tests/typing-immediate/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-immediate/immediate.ml b/testsuite/tests/typing-immediate/immediate.ml
index 996469f965821d9897b6c716a84d595344ab96e6..559e2a11c1e6f93e79ce95aa7c13fa3444811cf7 100644 (file)
--- a/testsuite/tests/typing-immediate/immediate.ml
+++ b/testsuite/tests/typing-immediate/immediate.ml
@@ -1,5 +1,9 @@
 module type S = sig type t [@@immediate] end;;
 module F (M : S) : S = M;;
+[%%expect{|
+module type S = sig type t [@@immediate] end
+module F : functor (M : S) -> S
+|}];;
 
 (* VALID DECLARATIONS *)
 
@@ -17,40 +21,74 @@ module A = struct
   type p = q [@@immediate]
   and q = int
 end;;
+[%%expect{|
+module A :
+  sig
+    type t [@@immediate]
+    type s = t [@@immediate]
+    type r = s
+    type p = q [@@immediate]
+    and q = int
+  end
+|}];;
 
 (* Valid using with constraints *)
 module type X = sig type t end;;
 module Y = struct type t = int end;;
 module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
+[%%expect{|
+module type X = sig type t end
+module Y : sig type t = int end
+module Z : sig type t [@@immediate] end
+|}];;
 
 (* Valid using an explicit signature *)
 module M_valid : S = struct type t = int end;;
 module FM_valid = F (struct type t = int end);;
+[%%expect{|
+module M_valid : S
+module FM_valid : S
+|}];;
 
 (* Practical usage over modules *)
 module Foo : sig type t val x : t ref end = struct
   type t = int
   let x = ref 0
 end;;
+[%%expect{|
+module Foo : sig type t val x : t ref end
+|}];;
 
 module Bar : sig type t [@@immediate] val x : t ref end = struct
   type t = int
   let x = ref 0
 end;;
+[%%expect{|
+module Bar : sig type t [@@immediate] val x : t ref end
+|}];;
 
 let test f =
   let start = Sys.time() in f ();
   (Sys.time() -. start);;
+[%%expect{|
+val test : (unit -> 'a) -> float = <fun>
+|}];;
 
 let test_foo () =
   for i = 0 to 100_000_000 do
     Foo.x := !Foo.x
   done;;
+[%%expect{|
+val test_foo : unit -> unit = <fun>
+|}];;
 
 let test_bar () =
   for i = 0 to 100_000_000 do
     Bar.x := !Bar.x
   done;;
+[%%expect{|
+val test_bar : unit -> unit = <fun>
+|}];;
 
 (* Uncomment these to test. Should see substantial speedup!
 let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
@@ -63,24 +101,62 @@ let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
 module B = struct
   type t = string [@@immediate]
 end;;
+[%%expect{|
+Line _, characters 2-31:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
 
 (* Not guaranteed that t is immediate, so this is an invalid declaration *)
 module C = struct
   type t
   type s = t [@@immediate]
 end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;
 
 (* Can't ascribe to an immediate type signature with a non-immediate type *)
 module D : sig type t [@@immediate] end = struct
   type t = string
 end;;
+[%%expect{|
+Line _, characters 42-70:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = string end
+       is not included in
+         sig type t [@@immediate] end
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
 
 (* Same as above but with explicit signature *)
 module M_invalid : S = struct type t = string end;;
 module FM_invalid = F (struct type t = string end);;
+[%%expect{|
+Line _, characters 23-49:
+Error: Signature mismatch:
+       Modules do not match: sig type t = string end is not included in S
+       Type declarations do not match:
+         type t = string
+       is not included in
+         type t [@@immediate]
+       the first is not an immediate type.
+|}];;
 
 (* Can't use a non-immediate type even if mutually recursive *)
 module E = struct
   type t = s [@@immediate]
   and s = string
 end;;
+[%%expect{|
+Line _, characters 2-26:
+Error: Types marked with the immediate attribute must be
+       non-pointer types like int or bool
+|}];;

diff --git a/testsuite/tests/typing-immediate/immediate.ml.reference b/testsuite/tests/typing-immediate/immediate.ml.reference
deleted file mode 100644 (file)
index d62a706..0000000
--- a/testsuite/tests/typing-immediate/immediate.ml.reference
+++ /dev/null
@@ -1,71 +0,0 @@
-
-# module type S = sig type t [@@immediate] end
-# module F : functor (M : S) -> S
-#                                 module A :
-  sig
-    type t [@@immediate]
-    type s = t [@@immediate]
-    type r = s
-    type p = q [@@immediate]
-    and q = int
-  end
-#     module type X = sig type t end
-# module Y : sig type t = int end
-# module Z : sig type t [@@immediate] end
-#     module M_valid : S
-# module FM_valid : S
-#           module Foo : sig type t val x : t ref end
-#         module Bar : sig type t [@@immediate] val x : t ref end
-#       val test : (unit -> 'a) -> float = <fun>
-#         val test_foo : unit -> unit = <fun>
-#         val test_bar : unit -> unit = <fun>
-#   * *                 Characters 306-335:
-    type t = string [@@immediate]
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
-       non-pointer types like int or bool
-#           Characters 106-130:
-    type s = t [@@immediate]
-    ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
-       non-pointer types like int or bool
-#         Characters 120-148:
-  ..........................................struct
-    type t = string
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = string end
-       is not included in
-         sig type t [@@immediate] end
-       Type declarations do not match:
-         type t = string
-       is not included in
-         type t [@@immediate]
-       the first is not an immediate type.
-#     Characters 72-98:
-  module M_invalid : S = struct type t = string end;;
-                         ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match: sig type t = string end is not included in S
-       Type declarations do not match:
-         type t = string
-       is not included in
-         type t [@@immediate]
-       the first is not an immediate type.
-# Characters 23-49:
-  module FM_invalid = F (struct type t = string end);;
-                         ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match: sig type t = string end is not included in S
-       Type declarations do not match:
-         type t = string
-       is not included in
-         type t [@@immediate]
-       the first is not an immediate type.
-#           Characters 85-109:
-    type t = s [@@immediate]
-    ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
-       non-pointer types like int or bool
-# 

diff --git a/testsuite/tests/typing-misc/Makefile b/testsuite/tests/typing-misc/Makefile
index 7fc00661cbe83513fbab37e2fe27d89365c35054..0b15e777de9b37e51d0594072c80e3eef907fd3e 100644 (file)
--- a/testsuite/tests/typing-misc/Makefile
+++ b/testsuite/tests/typing-misc/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml
index a00636325404b652733f6c5a77eba5808031b60c..76a360df0a21c58e90cb0185cf678f724badf94b 100644 (file)
--- a/testsuite/tests/typing-misc/constraints.ml
+++ b/testsuite/tests/typing-misc/constraints.ml
@@ -1,19 +1,52 @@
 type 'a t = [`A of 'a t t] as 'a;; (* fails *)
-
+[%%expect{|
+Line _, characters 0-32:
+Error: The definition of t contains a cycle:
+       'a t t as 'a
+|}, Principal{|
+Line _, characters 0-32:
+Error: The definition of t contains a cycle:
+       [ `A of 'a t t ] as 'a
+|}];;
 type 'a t = [`A of 'a t t];; (* fails *)
-
-type 'a t = [`A of 'a t t] constraint 'a = 'a t;;
-
-type 'a t = [`A of 'a t] constraint 'a = 'a t;;
-
+[%%expect{|
+Line _, characters 0-26:
+Error: In the definition of t, type 'a t t should be 'a t
+|}];;
+type 'a t = [`A of 'a t t] constraint 'a = 'a t;; (* fails since 4.04 *)
+[%%expect{|
+Line _, characters 0-47:
+Error: The type abbreviation t is cyclic
+|}];;
+type 'a t = [`A of 'a t] constraint 'a = 'a t;; (* fails since 4.04 *)
+[%%expect{|
+Line _, characters 0-45:
+Error: The type abbreviation t is cyclic
+|}];;
 type 'a t = [`A of 'a] as 'a;;
-
+[%%expect{|
+type 'a t = 'a constraint 'a = [ `A of 'a ]
+|}, Principal{|
+type 'a t = [ `A of 'b ] as 'b constraint 'a = [ `A of 'a ]
+|}];;
 type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
+[%%expect{|
+Line _, characters 0-41:
+Error: The definition of v contains a cycle:
+       t
+|}];;
 
 type 'a t = 'a;;
-let f (x : 'a t as 'a) = ();; (* fails *)
+let f (x : 'a t as 'a) = ();; (* ok *)
+[%%expect{|
+type 'a t = 'a
+val f : 'a -> unit = <fun>
+|}];;
 
 let f (x : 'a t) (y : 'a) = x = y;;
+[%%expect{|
+val f : 'a t -> 'a -> bool = <fun>
+|}];;
 
 (* PR#6505 *)
 module type PR6505 = sig
@@ -21,4 +54,59 @@ module type PR6505 = sig
   and 'o abs constraint 'o = 'o is_an_object
   val abs : 'o is_an_object -> 'o abs
   val unabs : 'o abs -> 'o
-end;; (* fails *)
+end
+;; (* fails *)
+[%%expect{|
+Line _, characters 2-44:
+Error: The definition of abs contains a cycle:
+       'a is_an_object as 'a
+|}];;
+
+module PR6505a = struct
+  type 'o is_an_object = < .. > as 'o
+  and ('k,'l) abs = 'l constraint 'k = 'l is_an_object
+  let y : ('o, 'o) abs = object end
+end;;
+let _ = PR6505a.y#bang;; (* fails *)
+[%%expect{|
+module PR6505a :
+  sig
+    type 'o is_an_object = 'o constraint 'o = < .. >
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val y : (<  > is_an_object, <  > is_an_object) abs
+  end
+Line _, characters 8-17:
+Error: This expression has type
+         (<  > PR6505a.is_an_object, <  > PR6505a.is_an_object) PR6505a.abs
+       It has no method bang
+|}, Principal{|
+module PR6505a :
+  sig
+    type 'o is_an_object = 'o constraint 'o = < .. >
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val y : (<  >, <  >) abs
+  end
+Line _, characters 8-17:
+Error: This expression has type (<  >, <  >) PR6505a.abs
+       It has no method bang
+|}]
+
+module PR6505b = struct
+  type 'o is_an_object = [> ] as 'o
+  and ('k,'l) abs = 'l constraint 'k = 'l is_an_object
+  let x : ('a, 'a) abs = `Foo 6
+end;;
+let () = print_endline (match PR6505b.x with `Bar s -> s);; (* fails *)
+[%%expect{|
+module PR6505b :
+  sig
+    type 'o is_an_object = 'o constraint 'o = [>  ]
+    and ('a, 'l) abs = 'l constraint 'a = 'l is_an_object
+    val x : (([> `Foo of int ] as 'a) is_an_object, 'a is_an_object) abs
+  end
+Line _, characters 23-57:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+`Foo _
+Exception: Match_failure ("", 6, 23).
+|}]

diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference
deleted file mode 100644 (file)
index 41a324c..0000000
--- a/testsuite/tests/typing-misc/constraints.ml.reference
+++ /dev/null
@@ -1,34 +0,0 @@
-
-# Characters 12-32:
-  type 'a t = [`A of 'a t t] as 'a;; (* fails *)
-              ^^^^^^^^^^^^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type
-       [ `A of 'a ] t t as 'a
-       should be an instance of
-       ([ `A of 'b t t ] as 'b) t
-#   Characters 1-27:
-  type 'a t = [`A of 'a t t];; (* fails *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of t, type 'a t t should be 'a t
-#   type 'a t = [ `A of 'a t t ] constraint 'a = 'a t
-#   type 'a t = [ `A of 'a t ] constraint 'a = 'a t
-#   type 'a t = 'a constraint 'a = [ `A of 'a ]
-#   Characters 43-52:
-  type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
-                                            ^^^^^^^^^
-Error: The type abbreviation t is cyclic
-#   type 'a t = 'a
-# Characters 11-21:
-  let f (x : 'a t as 'a) = ();; (* fails *)
-             ^^^^^^^^^^
-Error: This alias is bound to type 'a t = 'a
-       but is used as an instance of type 'a
-       The type variable 'a occurs inside 'a
-#   val f : 'a t -> 'a -> bool = <fun>
-#               Characters 80-122:
-    and 'o abs constraint 'o = 'o is_an_object
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The definition of abs contains a cycle:
-       'a is_an_object as 'a
-# 

diff --git a/testsuite/tests/typing-misc/labels.ml b/testsuite/tests/typing-misc/labels.ml
index 2d4b9d19d84f39b2aac4e2b2ecf5288a0bfad0c5..bd6c3a6f4e6abb075b44505525484596a170620c 100644 (file)
--- a/testsuite/tests/typing-misc/labels.ml
+++ b/testsuite/tests/typing-misc/labels.ml
@@ -1,11 +1,27 @@
 (* PR#5835 *)
 let f ~x = x + 1;;
 f ?x:0;;
+[%%expect{|
+val f : x:int -> int = <fun>
+Line _, characters 5-6:
+Warning 43: the label x is not optional.
+- : int = 1
+|}];;
 
 (* PR#6352 *)
 let foo (f : unit -> unit) = ();;
 let g ?x () = ();;
 foo ((); g);;
+[%%expect{|
+val foo : (unit -> unit) -> unit = <fun>
+val g : ?x:'a -> unit -> unit = <fun>
+- : unit = ()
+|}];;
 
 (* PR#5748 *)
 foo (fun ?opt () -> ()) ;; (* fails *)
+[%%expect{|
+Line _, characters 4-23:
+Error: This function should have type unit -> unit
+       but its first argument is labelled ?opt
+|}];;

diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference
deleted file mode 100644 (file)
index f8be126..0000000
--- a/testsuite/tests/typing-misc/labels.ml.principal.reference
+++ /dev/null
@@ -1,16 +0,0 @@
-
-#   val f : x:int -> int = <fun>
-# Characters 5-6:
-  f ?x:0;;
-       ^
-Warning 43: the label x is not optional.
-- : int = 1
-#     val foo : (unit -> unit) -> unit = <fun>
-# val g : ?x:'a -> unit -> unit = <fun>
-# - : unit = ()
-#     Characters 19-38:
-  foo (fun ?opt () -> ()) ;; (* fails *)
-      ^^^^^^^^^^^^^^^^^^^
-Error: This function should have type unit -> unit
-       but its first argument is labelled ?opt
-# 

diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference
deleted file mode 100644 (file)
index f8be126..0000000
--- a/testsuite/tests/typing-misc/labels.ml.reference
+++ /dev/null
@@ -1,16 +0,0 @@
-
-#   val f : x:int -> int = <fun>
-# Characters 5-6:
-  f ?x:0;;
-       ^
-Warning 43: the label x is not optional.
-- : int = 1
-#     val foo : (unit -> unit) -> unit = <fun>
-# val g : ?x:'a -> unit -> unit = <fun>
-# - : unit = ()
-#     Characters 19-38:
-  foo (fun ?opt () -> ()) ;; (* fails *)
-      ^^^^^^^^^^^^^^^^^^^
-Error: This function should have type unit -> unit
-       but its first argument is labelled ?opt
-# 

diff --git a/testsuite/tests/typing-misc/occur_check.ml b/testsuite/tests/typing-misc/occur_check.ml
index 5509b6f5ffaea164a28d5a7ad96d4900d4e9cb4f..c2c95f5637d736736c0490a0dec547e14e48d96d 100644 (file)
--- a/testsuite/tests/typing-misc/occur_check.ml
+++ b/testsuite/tests/typing-misc/occur_check.ml
@@ -2,4 +2,17 @@
 
 type 'a t = 'a;;
 let f (g : 'a list -> 'a t -> 'a) s = g s s;;
+[%%expect{|
+type 'a t = 'a
+Line _, characters 42-43:
+Error: This expression has type 'a list
+       but an expression was expected of type 'a t = 'a
+       The type variable 'a occurs inside 'a list
+|}];;
 let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
+[%%expect{|
+Line _, characters 42-43:
+Error: This expression has type 'a * 'b
+       but an expression was expected of type 'a t = 'a
+       The type variable 'a occurs inside 'a * 'b
+|}];;

diff --git a/testsuite/tests/typing-misc/occur_check.ml.reference b/testsuite/tests/typing-misc/occur_check.ml.reference
deleted file mode 100644 (file)
index 865c7d6..0000000
--- a/testsuite/tests/typing-misc/occur_check.ml.reference
+++ /dev/null
@@ -1,15 +0,0 @@
-
-#     type 'a t = 'a
-# Characters 42-43:
-  let f (g : 'a list -> 'a t -> 'a) s = g s s;;
-                                            ^
-Error: This expression has type 'a list
-       but an expression was expected of type 'a t = 'a
-       The type variable 'a occurs inside 'a list
-# Characters 42-43:
-  let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;;
-                                            ^
-Error: This expression has type 'a * 'b
-       but an expression was expected of type 'a t = 'a
-       The type variable 'a occurs inside 'a * 'b
-# 

diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml
index de8cb221bba0c77525e93520cf852d3a84a7b90c..a37eeb7bb6b2eefd2a671d6959c33cdd3d947091 100644 (file)
--- a/testsuite/tests/typing-misc/polyvars.ml
+++ b/testsuite/tests/typing-misc/polyvars.ml
@@ -1,10 +1,50 @@
 type ab = [ `A | `B ];;
 let f (x : [`A]) = match x with #ab -> 1;;
+[%%expect{|
+type ab = [ `A | `B ]
+Line _, characters 32-35:
+Error: This pattern matches values of type [? `A | `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}];;
 let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
+[%%expect{|
+Line _, characters 31-34:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}, Principal{|
+Line _, characters 31-34:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       Types for tag `B are incompatible
+|}];;
 let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
+[%%expect{|
+Line _, characters 34-36:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       The second variant type does not allow tag(s) `B
+|}, Principal{|
+Line _, characters 34-36:
+Error: This pattern matches values of type [? `B ]
+       but a pattern was expected which matches values of type [ `A ]
+       Types for tag `B are incompatible
+|}];;
 
 let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
+[%%expect{|
+Line _, characters 49-51:
+Warning 12: this sub-pattern is unused.
+val f : [< `A | `B ] -> int = <fun>
+|}];;
 let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+[%%expect{|
+Line _, characters 47-49:
+Error: This pattern matches values of type [? `C ]
+       but a pattern was expected which matches values of type [ `A | `B ]
+       The second variant type does not allow tag(s) `C
+|}];;
 
 (* PR#6787 *)
 let revapply x f = f x;;
@@ -13,3 +53,7 @@ let f x (g : [< `Foo]) =
   let y = `Bar x, g in
   revapply y (fun ((`Bar i), _) -> i);;
 (* f : 'a -> [< `Foo ] -> 'a *)
+[%%expect{|
+val revapply : 'a -> ('a -> 'b) -> 'b = <fun>
+val f : 'a -> [< `Foo ] -> 'a = <fun>
+|}];;

diff --git a/testsuite/tests/typing-misc/polyvars.ml.principal.reference b/testsuite/tests/typing-misc/polyvars.ml.principal.reference
deleted file mode 100644 (file)
index 6732640..0000000
--- a/testsuite/tests/typing-misc/polyvars.ml.principal.reference
+++ /dev/null
@@ -1,34 +0,0 @@
-
-# type ab = [ `A | `B ]
-# Characters 32-35:
-  let f (x : [`A]) = match x with #ab -> 1;;
-                                  ^^^
-Error: This pattern matches values of type [? `A | `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       The second variant type does not allow tag(s) `B
-# Characters 31-34:
-  let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
-                                 ^^^
-Error: This pattern matches values of type [? `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       Types for tag `B are incompatible
-# Characters 34-36:
-  let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
-                                    ^^
-Error: This pattern matches values of type [? `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       Types for tag `B are incompatible
-#   Characters 50-52:
-  let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
-                                                   ^^
-Warning 12: this sub-pattern is unused.
-val f : [< `A | `B ] -> int = <fun>
-# Characters 47-49:
-  let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
-                                                 ^^
-Error: This pattern matches values of type [? `C ]
-       but a pattern was expected which matches values of type [ `A | `B ]
-       The second variant type does not allow tag(s) `C
-#     val revapply : 'a -> ('a -> 'b) -> 'b = <fun>
-#       val f : 'a -> [< `Foo ] -> 'a = <fun>
-#   

diff --git a/testsuite/tests/typing-misc/polyvars.ml.reference b/testsuite/tests/typing-misc/polyvars.ml.reference
deleted file mode 100644 (file)
index 751b02f..0000000
--- a/testsuite/tests/typing-misc/polyvars.ml.reference
+++ /dev/null
@@ -1,34 +0,0 @@
-
-# type ab = [ `A | `B ]
-# Characters 32-35:
-  let f (x : [`A]) = match x with #ab -> 1;;
-                                  ^^^
-Error: This pattern matches values of type [? `A | `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       The second variant type does not allow tag(s) `B
-# Characters 31-34:
-  let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);;
-                                 ^^^
-Error: This pattern matches values of type [? `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       The second variant type does not allow tag(s) `B
-# Characters 34-36:
-  let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
-                                    ^^
-Error: This pattern matches values of type [? `B ]
-       but a pattern was expected which matches values of type [ `A ]
-       The second variant type does not allow tag(s) `B
-#   Characters 50-52:
-  let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
-                                                   ^^
-Warning 12: this sub-pattern is unused.
-val f : [< `A | `B ] -> int = <fun>
-# Characters 47-49:
-  let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
-                                                 ^^
-Error: This pattern matches values of type [? `C ]
-       but a pattern was expected which matches values of type [ `A | `B ]
-       The second variant type does not allow tag(s) `C
-#     val revapply : 'a -> ('a -> 'b) -> 'b = <fun>
-#       val f : 'a -> [< `Foo ] -> 'a = <fun>
-#   

diff --git a/testsuite/tests/typing-misc/pr6939.ml b/testsuite/tests/typing-misc/pr6939.ml
index 0ed82035000182876e1b0406973319660e622867..2acdd12ea7ab5898a7937ad99596b68b770d68ec 100755 (executable)
--- a/testsuite/tests/typing-misc/pr6939.ml
+++ b/testsuite/tests/typing-misc/pr6939.ml
@@ -1,4 +1,15 @@
-
 let rec x = [| x |]; 1.;;
+[%%expect{|
+Line _, characters 12-19:
+Warning 10: this expression should have type unit.
+Line _, characters 12-23:
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;
 
 let rec x = let u = [|y|] in 10. and y = 1.;;
+[%%expect{|
+Line _, characters 16-17:
+Warning 26: unused variable u.
+Line _, characters 12-32:
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;

diff --git a/testsuite/tests/typing-misc/pr6939.ml.reference b/testsuite/tests/typing-misc/pr6939.ml.reference
deleted file mode 100644 (file)
index 3a452cc..0000000
--- a/testsuite/tests/typing-misc/pr6939.ml.reference
+++ /dev/null
@@ -1,18 +0,0 @@
-
-#   Characters 13-20:
-  let rec x = [| x |]; 1.;;
-              ^^^^^^^
-Warning 10: this expression should have type unit.
-Characters 13-24:
-  let rec x = [| x |]; 1.;;
-              ^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#   Characters 17-18:
-  let rec x = let u = [|y|] in 10. and y = 1.;;
-                  ^
-Warning 26: unused variable u.
-Characters 13-33:
-  let rec x = let u = [|y|] in 10. and y = 1.;;
-              ^^^^^^^^^^^^^^^^^^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-# 

diff --git a/testsuite/tests/typing-misc/pr7103.ml b/testsuite/tests/typing-misc/pr7103.ml
index bdca4b343d9f73f09b9691ea0ab9749bd2f39388..f7420fd2bd16dab22e09284bfcd6290172367fd9 100644 (file)
--- a/testsuite/tests/typing-misc/pr7103.ml
+++ b/testsuite/tests/typing-misc/pr7103.ml
@@ -6,9 +6,34 @@ let f : < .. > t -> unit = fun _ -> ();;
 let g : [< `b] t -> unit = fun _ -> ();;
 
 let h : [> `b] t -> unit = fun _ -> ();;
+[%%expect{|
+type 'a t
+type a
+val f : < .. > t -> unit = <fun>
+val g : [< `b ] t -> unit = <fun>
+val h : [> `b ] t -> unit = <fun>
+|}];;
 
 let _ = fun (x : a t) -> f x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         (< .. > as 'a) t
+       Type a is not compatible with type < .. > as 'a
+|}];;
 
 let _ = fun (x : a t) -> g x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         ([< `b ] as 'a) t
+       Type a is not compatible with type [< `b ] as 'a
+|}];;
 
 let _ = fun (x : a t) -> h x;;
+[%%expect{|
+Line _, characters 27-28:
+Error: This expression has type a t but an expression was expected of type
+         ([> `b ] as 'a) t
+       Type a is not compatible with type [> `b ] as 'a
+|}];;

diff --git a/testsuite/tests/typing-misc/pr7103.ml.reference b/testsuite/tests/typing-misc/pr7103.ml.reference
deleted file mode 100644 (file)
index e745706..0000000
--- a/testsuite/tests/typing-misc/pr7103.ml.reference
+++ /dev/null
@@ -1,25 +0,0 @@
-
-#       type 'a t
-type a
-val f : < .. > t -> unit = <fun>
-#   val g : [< `b ] t -> unit = <fun>
-#   val h : [> `b ] t -> unit = <fun>
-#   Characters 28-29:
-  let _ = fun (x : a t) -> f x;;
-                             ^
-Error: This expression has type a t but an expression was expected of type
-         (< .. > as 'a) t
-       Type a is not compatible with type < .. > as 'a 
-#   Characters 28-29:
-  let _ = fun (x : a t) -> g x;;
-                             ^
-Error: This expression has type a t but an expression was expected of type
-         ([< `b ] as 'a) t
-       Type a is not compatible with type [< `b ] as 'a 
-#   Characters 28-29:
-  let _ = fun (x : a t) -> h x;;
-                             ^
-Error: This expression has type a t but an expression was expected of type
-         ([> `b ] as 'a) t
-       Type a is not compatible with type [> `b ] as 'a 
-# 

diff --git a/testsuite/tests/typing-misc/pr7228.ml b/testsuite/tests/typing-misc/pr7228.ml
new file mode 100755 (executable)
index 0000000..a9f0cb1
--- /dev/null
+++ b/testsuite/tests/typing-misc/pr7228.ml
@@ -0,0 +1,15 @@
+type t = A of {mutable x: int};;
+fun (A r) -> r.x <- 42;;
+[%%expect{|
+type t = A of { mutable x : int; }
+- : t -> unit = <fun>
+|}];;
+
+(* Check that mutability is blocked for inline records on private types *)
+type t = private A of {mutable x: int};;
+fun (A r) -> r.x <- 42;;
+[%%expect{|
+type t = private A of { mutable x : int; }
+Line _, characters 15-16:
+Error: Cannot assign field x of the private type t.A
+|}];;

diff --git a/testsuite/tests/typing-misc/printing.ml b/testsuite/tests/typing-misc/printing.ml
index 8a9c23108f11cd5ee4b5d91114128d27892de6d1..277c386425cebb6e6d4d6a0263d0fe30beb803cc 100644 (file)
--- a/testsuite/tests/typing-misc/printing.ml
+++ b/testsuite/tests/typing-misc/printing.ml
@@ -1,7 +1,18 @@
 (* PR#7012 *)
 
 type t = [ 'A_name | `Hi ];;
+[%%expect{|
+Line _, characters 11-18:
+Error: The type 'A_name is not a polymorphic variant type
+Hint: Did you mean `A_name?
+|}];;
 
 let f (x:'id_arg) = x;;
+[%%expect{|
+val f : 'id_arg -> 'id_arg = <fun>
+|}];;
 
 let f (x:'Id_arg) = x;;
+[%%expect{|
+val f : 'Id_arg -> 'Id_arg = <fun>
+|}];;

diff --git a/testsuite/tests/typing-misc/printing.ml.reference b/testsuite/tests/typing-misc/printing.ml.reference
deleted file mode 100644 (file)
index 21763b2..0000000
--- a/testsuite/tests/typing-misc/printing.ml.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-
-#     Characters 26-33:
-  type t = [ 'A_name | `Hi ];;
-             ^^^^^^^
-Error: The type 'A_name is not a polymorphic variant type
-Hint: Did you mean `A_name?
-#   val f : 'id_arg -> 'id_arg = <fun>
-#   val f : 'Id_arg -> 'Id_arg = <fun>
-# 

diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml
index ae296cf1256e1c0497c38a86cf6aa005481b516e..f6d9100cad1391e69cc27845abda3f89c4eed405 100644 (file)
--- a/testsuite/tests/typing-misc/records.ml
+++ b/testsuite/tests/typing-misc/records.ml
@@ -1,38 +1,112 @@
 (* undefined labels *)
 type t = {x:int;y:int};;
 {x=3;z=2};;
+[%%expect{|
+type t = { x : int; y : int; }
+Line _, characters 5-6:
+Error: Unbound record field z
+|}];;
 fun {x=3;z=2} -> ();;
+[%%expect{|
+Line _, characters 9-10:
+Error: Unbound record field z
+|}];;
 
 (* mixed labels *)
 {x=3; contents=2};;
+[%%expect{|
+Line _, characters 6-14:
+Error: The record field contents belongs to the type 'a ref
+       but is mixed here with fields of type t
+|}];;
 
 (* private types *)
 type u = private {mutable u:int};;
 {u=3};;
+[%%expect{|
+type u = private { mutable u : int; }
+Line _, characters 0-5:
+Error: Cannot create values of the private type u
+|}];;
 fun x -> x.u <- 3;;
+[%%expect{|
+Line _, characters 11-12:
+Error: Cannot assign field u of the private type u
+|}];;
 
 (* Punning and abbreviations *)
 module M = struct
   type t = {x: int; y: int}
 end;;
+[%%expect{|
+module M : sig type t = { x : int; y : int; } end
+|}];;
 
 let f {M.x; y} = x+y;;
 let r = {M.x=1; y=2};;
 let z = f r;;
+[%%expect{|
+val f : M.t -> int = <fun>
+val r : M.t = {M.x = 1; y = 2}
+val z : int = 3
+|}];;
 
 (* messages *)
 type foo = { mutable y:int };;
 let f (r: int) = r.y <- 3;;
+[%%expect{|
+type foo = { mutable y : int; }
+Line _, characters 17-18:
+Error: This expression has type int but an expression was expected of type
+         foo
+|}];;
 
 (* bugs *)
 type foo = { y: int; z: int };;
 type bar = { x: int };;
 let f (r: bar) = ({ r with z = 3 } : foo)
+[%%expect{|
+type foo = { y : int; z : int; }
+type bar = { x : int; }
+Line _, characters 20-21:
+Error: This expression has type bar but an expression was expected of type
+         foo
+|}];;
 
 type foo = { x: int };;
 let r : foo = { ZZZ.x = 2 };;
+[%%expect{|
+type foo = { x : int; }
+Line _, characters 16-21:
+Error: Unbound module ZZZ
+|}];;
 
 (ZZZ.X : int option);;
+[%%expect{|
+Line _, characters 1-6:
+Error: Unbound module ZZZ
+|}];;
 
 (* PR#5865 *)
 let f (x : Complex.t) = x.Complex.z;;
+[%%expect{|
+Line _, characters 26-35:
+Error: Unbound record field Complex.z
+|}];;
+
+
+(* PR#6608 *)
+{ "reference" with contents = 0 }
+[%%expect{|
+Line _, characters 0-33:
+Warning 23: all the fields are explicitly listed in this record:
+the 'with' clause is useless.
+- : int ref = {contents = 0}
+|}];;
+{ true with contents = 0 }
+[%%expect{|
+Line _, characters 0-26:
+Warning 23: all the fields are explicitly listed in this record:
+the 'with' clause is useless.
+- : int ref = {contents = 0}
+|}];;

diff --git a/testsuite/tests/typing-misc/records.ml.principal.reference b/testsuite/tests/typing-misc/records.ml.principal.reference
deleted file mode 100644 (file)
index f084d03..0000000
--- a/testsuite/tests/typing-misc/records.ml.principal.reference
+++ /dev/null
@@ -1,54 +0,0 @@
-
-#   type t = { x : int; y : int; }
-# Characters 5-6:
-  {x=3;z=2};;
-       ^
-Error: Unbound record field z
-# Characters 9-10:
-  fun {x=3;z=2} -> ();;
-           ^
-Error: Unbound record field z
-#     Characters 26-34:
-  {x=3; contents=2};;
-        ^^^^^^^^
-Error: The record field contents belongs to the type 'a ref
-       but is mixed here with fields of type t
-#     type u = private { mutable u : int; }
-# Characters 0-5:
-  {u=3};;
-  ^^^^^
-Error: Cannot create values of the private type u
-# Characters 11-12:
-  fun x -> x.u <- 3;;
-             ^
-Error: Cannot assign field u of the private type u
-#         module M : sig type t = { x : int; y : int; } end
-#   val f : M.t -> int = <fun>
-# val r : M.t = {M.x = 1; y = 2}
-# val z : int = 3
-#     type foo = { mutable y : int; }
-# Characters 17-18:
-  let f (r: int) = r.y <- 3;;
-                   ^
-Error: This expression has type int but an expression was expected of type
-         foo
-#     type foo = { y : int; z : int; }
-# type bar = { x : int; }
-#     Characters 20-21:
-  let f (r: bar) = ({ r with z = 3 } : foo)
-                      ^
-Error: This expression has type bar but an expression was expected of type
-         foo
-# Characters 16-21:
-  let r : foo = { ZZZ.x = 2 };;
-                  ^^^^^
-Error: Unbound module ZZZ
-#   Characters 2-7:
-  (ZZZ.X : int option);;
-   ^^^^^
-Error: Unbound module ZZZ
-#     Characters 41-50:
-  let f (x : Complex.t) = x.Complex.z;;
-                            ^^^^^^^^^
-Error: Unbound record field Complex.z
-# 

diff --git a/testsuite/tests/typing-misc/records.ml.reference b/testsuite/tests/typing-misc/records.ml.reference
deleted file mode 100644 (file)
index f084d03..0000000
--- a/testsuite/tests/typing-misc/records.ml.reference
+++ /dev/null
@@ -1,54 +0,0 @@
-
-#   type t = { x : int; y : int; }
-# Characters 5-6:
-  {x=3;z=2};;
-       ^
-Error: Unbound record field z
-# Characters 9-10:
-  fun {x=3;z=2} -> ();;
-           ^
-Error: Unbound record field z
-#     Characters 26-34:
-  {x=3; contents=2};;
-        ^^^^^^^^
-Error: The record field contents belongs to the type 'a ref
-       but is mixed here with fields of type t
-#     type u = private { mutable u : int; }
-# Characters 0-5:
-  {u=3};;
-  ^^^^^
-Error: Cannot create values of the private type u
-# Characters 11-12:
-  fun x -> x.u <- 3;;
-             ^
-Error: Cannot assign field u of the private type u
-#         module M : sig type t = { x : int; y : int; } end
-#   val f : M.t -> int = <fun>
-# val r : M.t = {M.x = 1; y = 2}
-# val z : int = 3
-#     type foo = { mutable y : int; }
-# Characters 17-18:
-  let f (r: int) = r.y <- 3;;
-                   ^
-Error: This expression has type int but an expression was expected of type
-         foo
-#     type foo = { y : int; z : int; }
-# type bar = { x : int; }
-#     Characters 20-21:
-  let f (r: bar) = ({ r with z = 3 } : foo)
-                      ^
-Error: This expression has type bar but an expression was expected of type
-         foo
-# Characters 16-21:
-  let r : foo = { ZZZ.x = 2 };;
-                  ^^^^^
-Error: Unbound module ZZZ
-#   Characters 2-7:
-  (ZZZ.X : int option);;
-   ^^^^^
-Error: Unbound module ZZZ
-#     Characters 41-50:
-  let f (x : Complex.t) = x.Complex.z;;
-                            ^^^^^^^^^
-Error: Unbound record field Complex.z
-# 

diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml
index b0bd52227749c0cf344dee44b8b182a79192048a..de83454ade03e26d69d577a449555c6a5c50c3ef 100644 (file)
--- a/testsuite/tests/typing-misc/variant.ml
+++ b/testsuite/tests/typing-misc/variant.ml
@@ -6,3 +6,15 @@ end = struct
  type t = A | B
  let f = function A | B -> 0
 end;;
+[%%expect{|
+Line _, characters 6-61:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = X.t = A | B val f : t -> int end
+       is not included in
+         sig type t = int * bool end
+       Type declarations do not match:
+         type t = X.t = A | B
+       is not included in
+         type t = int * bool
+|}];;

diff --git a/testsuite/tests/typing-misc/variant.ml.reference b/testsuite/tests/typing-misc/variant.ml.reference
deleted file mode 100644 (file)
index 4de6b61..0000000
--- a/testsuite/tests/typing-misc/variant.ml.reference
+++ /dev/null
@@ -1,16 +0,0 @@
-
-#               Characters 61-116:
-  ......struct
-   type t = A | B
-   let f = function A | B -> 0
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = X.t = A | B val f : t -> int end
-       is not included in
-         sig type t = int * bool end
-       Type declarations do not match:
-         type t = X.t = A | B
-       is not included in
-         type t = int * bool
-# 

diff --git a/testsuite/tests/typing-misc/wellfounded.ml b/testsuite/tests/typing-misc/wellfounded.ml
index b33adc5e1775dcbde40f0f480e493dadd77833c7..99dc4c97fc3adfb6c031a9f03c404c05372956d9 100644 (file)
--- a/testsuite/tests/typing-misc/wellfounded.ml
+++ b/testsuite/tests/typing-misc/wellfounded.ml
@@ -9,3 +9,8 @@ let f : type t. t prod -> _ = function Prod ->
     end
   in ()
 ;;
+[%%expect{|
+type _ prod = Prod : ('a * 'y) prod
+Line _, characters 6-20:
+Error: The type abbreviation d is cyclic
+|}];;

diff --git a/testsuite/tests/typing-misc/wellfounded.ml.principal.reference b/testsuite/tests/typing-misc/wellfounded.ml.principal.reference
deleted file mode 100644 (file)
index 04bf558..0000000
--- a/testsuite/tests/typing-misc/wellfounded.ml.principal.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-#     type _ prod = Prod : ('a * 'y) prod
-#               Characters 82-96:
-        type d = d * d
-        ^^^^^^^^^^^^^^
-Error: The type abbreviation d is cyclic
-# 

diff --git a/testsuite/tests/typing-misc/wellfounded.ml.reference b/testsuite/tests/typing-misc/wellfounded.ml.reference
deleted file mode 100644 (file)
index 04bf558..0000000
--- a/testsuite/tests/typing-misc/wellfounded.ml.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-#     type _ prod = Prod : ('a * 'y) prod
-#               Characters 82-96:
-        type d = d * d
-        ^^^^^^^^^^^^^^
-Error: The type abbreviation d is cyclic
-# 

diff --git a/testsuite/tests/typing-missing-cmi/Makefile b/testsuite/tests/typing-missing-cmi/Makefile
index 6a18f649be08e6db4b2eea5639133d2a181ccafa..bc0ce930171d4562e6a461ce1e82eee4b8b5f002 100644 (file)
--- a/testsuite/tests/typing-missing-cmi/Makefile
+++ b/testsuite/tests/typing-missing-cmi/Makefile
@@ -1,13 +1,21 @@
+# Tests for compilation with missing cmis
+# main.ml: error message when equality is missing
+# main_ok.ml: allow path expansion even when the target is missing (GPR#816)
+
+SOURCES = subdir/m.ml a.ml b.ml c.ml main.ml main_ok.ml
 
 .PHONY: default
-default: subdir/m.ml a.ml b.ml main.ml
+default: $(SOURCES)
        @printf " ... testing 'main.ml'";
        @$(OCAMLC) -c subdir/m.ml;
        @$(OCAMLC) -c -I subdir a.ml;
        @$(OCAMLC) -c -I subdir b.ml;
+       @$(OCAMLC) -c -I subdir c.ml;
        @$(OCAMLC) -c main.ml > main.ml.result 2>&1 || :
        @$(DIFF) main.ml.result main.ml.reference >/dev/null \
        && echo " => passed" || echo " => failed"
+       @printf " ... testing 'main_ok.ml'";
+       @$(OCAMLC) -c main_ok.ml && echo " => passed" || echo " => failed"
 
 .PHONY: clean
 clean:

diff --git a/testsuite/tests/typing-missing-cmi/c.ml b/testsuite/tests/typing-missing-cmi/c.ml
new file mode 100644 (file)
index 0000000..35a6ce5
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/c.ml
@@ -0,0 +1,10 @@
+(* GPR#816 *)
+(* This PR means that Foo(Bar).t is known to be equal to Foo(Baz).t
+   when Bar is an alias for Baz, even when the definition for Foo is unknown.
+   This can happen when .cmi files depend on other .cmi files not in the path
+   -- a situation that is partially supported. *)
+
+module A = M
+
+type t1 = M.Foo(M).t
+type t2 = A.Foo(A).t

diff --git a/testsuite/tests/typing-missing-cmi/main_ok.ml b/testsuite/tests/typing-missing-cmi/main_ok.ml
new file mode 100644 (file)
index 0000000..e690719
--- /dev/null
+++ b/testsuite/tests/typing-missing-cmi/main_ok.ml
@@ -0,0 +1 @@
+let f (x : C.t1) = (x : C.t2)

diff --git a/testsuite/tests/typing-missing-cmi/subdir/m.ml b/testsuite/tests/typing-missing-cmi/subdir/m.ml
index 32870c88cc25f8d98235451207a5230f177ab7d0..c939a6a66737d3c071f296782b96d96cdda96690 100644 (file)
--- a/testsuite/tests/typing-missing-cmi/subdir/m.ml
+++ b/testsuite/tests/typing-missing-cmi/subdir/m.ml
@@ -1,2 +1,4 @@
 type a = int
 type b = a
+
+module Foo(X : sig end) = struct type t = T end

diff --git a/testsuite/tests/typing-modules-bugs/pr6752_bad.ml b/testsuite/tests/typing-modules-bugs/pr6752_bad.ml
new file mode 100644 (file)
index 0000000..6f0f5f4
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6752_bad.ml
@@ -0,0 +1,46 @@
+(* Sorry, we have to disable this as this requires accepting
+   potentially badly formed programs (after expliciting) *)
+
+module Common0 =
+ struct
+   type msg = Msg
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+let q' : Common0.msg Queue.t = Common0.q
+
+module Common =
+ struct
+   type msg = ..
+
+   let handle_msg = ref (function _ -> failwith "Unable to handle message")
+   let extend_handle f =
+   let old = !handle_msg in
+   handle_msg := f old
+
+   let q : _ Queue.t = Queue.create ()
+   let add msg = Queue.add msg q
+   let handle_queue_messages () = Queue.iter !handle_msg q
+ end
+
+module M1 =
+ struct
+   type Common.msg += Reload of string | Alert of string
+
+   let handle fallback = function
+     Reload s -> print_endline ("Reload "^s)
+   | Alert s -> print_endline ("Alert "^s)
+   | x -> fallback x
+
+   let () = Common.extend_handle handle
+   let () = Common.add (Reload "config.file")
+   let () = Common.add (Alert "Initialisation done")
+ end

diff --git a/testsuite/tests/typing-modules-bugs/pr6752_ok.ml b/testsuite/tests/typing-modules-bugs/pr6752_ok.ml
index 846af0d178cf2407f29588eb36fa4daba41b3af5..cc342ec65300462c29c0862c52a180d3ef55b884 100644 (file)
--- a/testsuite/tests/typing-modules-bugs/pr6752_ok.ml
+++ b/testsuite/tests/typing-modules-bugs/pr6752_ok.ml
@@ -1,3 +1,5 @@
+(* Adding a type annotation is sufficient to make typing go through *)
+
 module Common0 =
  struct
    type msg = Msg
@@ -7,7 +9,7 @@ module Common0 =
    let old = !handle_msg in
    handle_msg := f old
 
-   let q : _ Queue.t = Queue.create ()
+   let q : msg Queue.t = Queue.create ()
    let add msg = Queue.add msg q
    let handle_queue_messages () = Queue.iter !handle_msg q
  end
@@ -23,7 +25,7 @@ module Common =
    let old = !handle_msg in
    handle_msg := f old
 
-   let q : _ Queue.t = Queue.create ()
+   let q : msg Queue.t = Queue.create ()
    let add msg = Queue.add msg q
    let handle_queue_messages () = Queue.iter !handle_msg q
  end

diff --git a/testsuite/tests/typing-modules-bugs/pr7112_bad.ml b/testsuite/tests/typing-modules-bugs/pr7112_bad.ml
new file mode 100644 (file)
index 0000000..9f4a12d
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7112_bad.ml
@@ -0,0 +1,5 @@
+module A = struct module type S module S = struct end end
+module F (_ : sig end) = struct module type S module S = A.S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : A.S = X

diff --git a/testsuite/tests/typing-modules-bugs/pr7112_ok.ml b/testsuite/tests/typing-modules-bugs/pr7112_ok.ml
new file mode 100644 (file)
index 0000000..9da5606
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7112_ok.ml
@@ -0,0 +1,4 @@
+module F (_ : sig end) = struct module type S end
+module M = struct end
+module N = M
+module G (X : F(N).S) : F(M).S = X

diff --git a/testsuite/tests/typing-modules-bugs/pr7152_ok.ml b/testsuite/tests/typing-modules-bugs/pr7152_ok.ml
index 59491f35e84039ed0f48e6715becf355275d62d1..662d8c266094c9b7cd6cb2404d945a0023f028ea 100644 (file)
--- a/testsuite/tests/typing-modules-bugs/pr7152_ok.ml
+++ b/testsuite/tests/typing-modules-bugs/pr7152_ok.ml
@@ -33,6 +33,49 @@ end = struct
     let key = Fast.create ()
   end
 
+  let _ = Dem.key (* force to evaluation the lazy substitution *)
+
+  module EDem = Fast.Register(Dem)
+
+  let add_dec dec =
+    Fast.attach Dem.key dec
+end
+
+(* variant without using a Data module *)
+
+module M' :  sig
+  type make_dec
+  val add_dec: make_dec -> unit
+end = struct
+  type u
+
+  module Fast: sig
+    type 'd t
+    val create: unit -> 'd t
+    module type S = sig
+      type data
+      val key: data t
+    end
+    module Register (D:S): sig end
+    val attach: 'd t -> 'd -> unit
+  end = struct
+    type 'd t = unit
+    let create () = ()
+    module type S = sig
+      type data
+      val key: data t
+    end
+    module Register (D:S) = struct end
+    let attach _ _ = ()
+  end
+
+  type make_dec
+
+  module Dem = struct
+    type data = make_dec
+    let key = Fast.create ()
+  end
+
   module EDem = Fast.Register(Dem)
 
   let add_dec dec =

diff --git a/testsuite/tests/typing-modules-bugs/pr7305_principal.ml b/testsuite/tests/typing-modules-bugs/pr7305_principal.ml
new file mode 100644 (file)
index 0000000..fd20e99
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7305_principal.ml
@@ -0,0 +1,29 @@
+type c1 = < c1: c1 >
+type c2 = < c1: c1; c2: c1; c3: c1; c4: c1; c5: c1; c6: c1 >
+type c3 = < c1: c2; c2: c2; c3: c2; c4: c2; c5: c2; c6: c2 >
+type c4 = < c1: c3; c2: c3; c3: c3; c4: c3; c5: c3; c6: c3 >
+type c5 = < c1: c4; c2: c4; c3: c4; c4: c4; c5: c4; c6: c4 >
+type c6 = < c1: c5; c2: c5; c3: c5; c4: c5; c5: c5; c6: c5 >
+type c7 = < c1: c6; c2: c6; c3: c6; c4: c6; c5: c6; c6: c6 >
+
+(* If you use this example, then checking the types themselves
+   takes a long time.
+type c1 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c2 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c3 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c4 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c5 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+and  c6 = < c1: c1; c2: c2; c3: c3; c4: c4; c5: c5; c6: c6 >
+*)
+
+(* Same for this example
+type 'a c1 = <c1: 'a c1>
+type 'a c2 = <c1: 'a c1; c2: 'a c1; c3: 'a c1; c4: 'a c1; c5: 'a c1; c6: 'a c1>
+type 'a c3 = <c1: 'a c2; c2: 'a c2; c3: 'a c2; c4: 'a c2; c5: 'a c2; c6: 'a c2>
+type 'a c4 = <c1: 'a c3; c2: 'a c3; c3: 'a c3; c4: 'a c3; c5: 'a c3; c6: 'a c3>
+type 'a c5 = <c1: 'a c4; c2: 'a c4; c3: 'a c4; c4: 'a c4; c5: 'a c4; c6: 'a c4>
+type 'a c6 = <c1: 'a c5; c2: 'a c5; c3: 'a c5; c4: 'a c5; c5: 'a c5; c6: 'a c5>
+type 'a c7 = <c1: 'a c6; c2: 'a c6; c3: 'a c6; c4: 'a c6; c5: 'a c6; c6: 'a c6>
+*)
+
+let x = ref ([] : c7 list)

diff --git a/testsuite/tests/typing-modules/Makefile b/testsuite/tests/typing-modules/Makefile
index 7fc00661cbe83513fbab37e2fe27d89365c35054..0b15e777de9b37e51d0594072c80e3eef907fd3e 100644 (file)
--- a/testsuite/tests/typing-modules/Makefile
+++ b/testsuite/tests/typing-modules/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml
index 640655eb12fc2d581489d89f8a0ffabcd44bba9e..149ba15463559dd604b5a6255dadc671554581b6 100644 (file)
--- a/testsuite/tests/typing-modules/Test.ml
+++ b/testsuite/tests/typing-modules/Test.ml
@@ -2,9 +2,17 @@
 
 module type S = sig type t and s = t end;;
 module type S' = S with type t := int;;
+[%%expect{|
+module type S = sig type t and s = t end
+module type S' = sig type s = int end
+|}];;
 
 module type S = sig module rec M : sig end and N : sig end end;;
 module type S' = S with module M := String;;
+[%%expect{|
+module type S = sig module rec M : sig  end and N : sig  end end
+module type S' = sig module rec N : sig  end end
+|}];;
 
 (* with module type *)
 (*
@@ -30,33 +38,74 @@ type -'a t
 class type c = object method m : [ `A ] t end;;
 module M : sig val v : (#c as 'a) -> 'a end =
   struct let v x = ignore (x :> c); x end;;
+[%%expect{|
+type -'a t
+class type c = object method m : [ `A ] t end
+module M : sig val v : (#c as 'a) -> 'a end
+|}];;
 
 (* PR#4838 *)
 
 let id = let module M = struct end in fun x -> x;;
+[%%expect{|
+val id : 'a -> 'a = <fun>
+|}];;
 
 (* PR#4511 *)
 
 let ko = let module M = struct end in fun _ -> ();;
+[%%expect{|
+val ko : 'a -> unit = <fun>
+|}];;
 
 (* PR#5993 *)
 
 module M : sig type -'a t = private int end =
   struct type +'a t = private int end
 ;;
+[%%expect{|
+Line _, characters 2-37:
+Error: Signature mismatch:
+       Modules do not match:
+         sig type +'a t = private int end
+       is not included in
+         sig type -'a t = private int end
+       Type declarations do not match:
+         type +'a t = private int
+       is not included in
+         type -'a t = private int
+       Their variances do not agree.
+|}];;
 
 (* PR#6005 *)
 
 module type A = sig type t = X of int end;;
 type u = X of bool;;
 module type B = A with type t = u;; (* fail *)
+[%%expect{|
+module type A = sig type t = X of int end
+type u = X of bool
+Line _, characters 23-33:
+Error: This variant or record definition does not match that of type u
+       The types for field X are not equal.
+|}];;
 
 (* PR#5815 *)
 (* ---> duplicated exception name is now an error *)
 
 module type S = sig exception Foo of int  exception Foo of bool end;;
+[%%expect{|
+Line _, characters 52-55:
+Error: Multiple definition of the extension constructor name Foo.
+       Names must be unique in a given structure or signature.
+|}];;
 
 (* PR#6410 *)
 
 module F(X : sig end) = struct let x = 3 end;;
 F.x;; (* fail *)
+[%%expect{|
+module F : functor (X : sig  end) -> sig val x : int end
+Line _, characters 0-3:
+Error: The module F is a functor, not a structure
+|}];;

diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference
deleted file mode 100644 (file)
index 9646d3d..0000000
--- a/testsuite/tests/typing-modules/Test.ml.principal.reference
+++ /dev/null
@@ -1,41 +0,0 @@
-
-#     module type S = sig type t and s = t end
-# module type S' = sig type s = int end
-#   module type S = sig module rec M : sig  end and N : sig  end end
-# module type S' = sig module rec N : sig  end end
-#     * * * * * * * * * * * * * * * *         type -'a t
-class type c = object method m : [ `A ] t end
-#   module M : sig val v : (#c as 'a) -> 'a end
-#       val id : 'a -> 'a = <fun>
-#       val ko : 'a -> unit = <fun>
-#           Characters 64-99:
-    struct type +'a t = private int end
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig type +'a t = private int end
-       is not included in
-         sig type -'a t = private int end
-       Type declarations do not match:
-         type +'a t = private int
-       is not included in
-         type -'a t = private int
-       Their variances do not agree.
-#       module type A = sig type t = X of int end
-# type u = X of bool
-# Characters 23-33:
-  module type B = A with type t = u;; (* fail *)
-                         ^^^^^^^^^^
-Error: This variant or record definition does not match that of type u
-       The types for field X are not equal.
-#         Characters 121-124:
-  module type S = sig exception Foo of int  exception Foo of bool end;;
-                                                      ^^^
-Error: Multiple definition of the extension constructor name Foo.
-       Names must be unique in a given structure or signature.
-#       module F : functor (X : sig  end) -> sig val x : int end
-# Characters 0-3:
-  F.x;; (* fail *)
-  ^^^
-Error: The module F is a functor, not a structure
-# 

diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference
deleted file mode 100644 (file)
index 9646d3d..0000000
--- a/testsuite/tests/typing-modules/Test.ml.reference
+++ /dev/null
@@ -1,41 +0,0 @@
-
-#     module type S = sig type t and s = t end
-# module type S' = sig type s = int end
-#   module type S = sig module rec M : sig  end and N : sig  end end
-# module type S' = sig module rec N : sig  end end
-#     * * * * * * * * * * * * * * * *         type -'a t
-class type c = object method m : [ `A ] t end
-#   module M : sig val v : (#c as 'a) -> 'a end
-#       val id : 'a -> 'a = <fun>
-#       val ko : 'a -> unit = <fun>
-#           Characters 64-99:
-    struct type +'a t = private int end
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig type +'a t = private int end
-       is not included in
-         sig type -'a t = private int end
-       Type declarations do not match:
-         type +'a t = private int
-       is not included in
-         type -'a t = private int
-       Their variances do not agree.
-#       module type A = sig type t = X of int end
-# type u = X of bool
-# Characters 23-33:
-  module type B = A with type t = u;; (* fail *)
-                         ^^^^^^^^^^
-Error: This variant or record definition does not match that of type u
-       The types for field X are not equal.
-#         Characters 121-124:
-  module type S = sig exception Foo of int  exception Foo of bool end;;
-                                                      ^^^
-Error: Multiple definition of the extension constructor name Foo.
-       Names must be unique in a given structure or signature.
-#       module F : functor (X : sig  end) -> sig val x : int end
-# Characters 0-3:
-  F.x;; (* fail *)
-  ^^^
-Error: The module F is a functor, not a structure
-# 

diff --git a/testsuite/tests/typing-modules/a.mli b/testsuite/tests/typing-modules/a.mli
deleted file mode 100644 (file)
index ea15bf0..0000000
--- a/testsuite/tests/typing-modules/a.mli
+++ /dev/null
@@ -1,3 +0,0 @@
-module L = List
-module S = String
-module D' = D

diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml
index 7580bebe7cb275ff8a8d64734f9fd222639a40cf..b318543ea6382618dc2695d9a71e2588c913b7e3 100644 (file)
--- a/testsuite/tests/typing-modules/aliases.ml
+++ b/testsuite/tests/typing-modules/aliases.ml
@@ -6,22 +6,100 @@ C'.chr 66;;
 
 module C3 = struct include Char end;;
 C3.chr 66;;
+[%%expect{|
+module C = Char
+- : char = 'B'
+module C' :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+module C3 :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+|}];;
 
 let f x = let module M = struct module L = List end in M.L.length x;;
 let g x = let module L = List in L.length (L.map succ x);;
+[%%expect{|
+val f : 'a list -> int = <fun>
+val g : int list -> int = <fun>
+|}];;
 
 module F(X:sig end) = Char;;
 module C4 = F(struct end);;
 C4.chr 66;;
+[%%expect{|
+module F :
+  functor (X : sig  end) ->
+    sig
+      external code : char -> int = "%identity"
+      val chr : int -> char
+      val escaped : char -> string
+      val lowercase : char -> char
+      val uppercase : char -> char
+      val lowercase_ascii : char -> char
+      val uppercase_ascii : char -> char
+      type t = char
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      external unsafe_chr : int -> char = "%identity"
+    end
+module C4 :
+  sig
+    external code : char -> int = "%identity"
+    val chr : int -> char
+    val escaped : char -> string
+    val lowercase : char -> char
+    val uppercase : char -> char
+    val lowercase_ascii : char -> char
+    val uppercase_ascii : char -> char
+    type t = char
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    external unsafe_chr : int -> char = "%identity"
+  end
+- : char = 'B'
+|}];;
 
 module G(X:sig end) = struct module M = X end;; (* does not alias X *)
 module M = G(struct end);;
+[%%expect{|
+module G : functor (X : sig  end) -> sig module M : sig  end end
+module M : sig module M : sig  end end
+|}];;
 
 module M' = struct
   module N = struct let x = 1 end
   module N' = N
 end;;
 M'.N'.x;;
+[%%expect{|
+module M' : sig module N : sig val x : int end module N' = N end
+- : int = 1
+|}];;
 
 module M'' : sig module N' : sig val x : int end end = M';;
 M''.N'.x;;
@@ -30,12 +108,25 @@ module M3 : sig module N' : sig val x : int end end = struct include M' end;;
 M3.N'.x;;
 module M3' : sig module N' : sig val x : int end end = M2;;
 M3'.N'.x;;
+[%%expect{|
+module M'' : sig module N' : sig val x : int end end
+- : int = 1
+module M2 : sig module N = M'.N module N' = N end
+module M3 : sig module N' : sig val x : int end end
+- : int = 1
+module M3' : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
 
 module M4 : sig module N' : sig val x : int end end = struct
   module N = struct let x = 1 end
   module N' = N
 end;;
 M4.N'.x;;
+[%%expect{|
+module M4 : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
 
 module F(X:sig end) = struct
   module N = struct let x = 1 end
@@ -44,6 +135,14 @@ end;;
 module G : functor(X:sig end) -> sig module N' : sig val x : int end end = F;;
 module M5 = G(struct end);;
 M5.N'.x;;
+[%%expect{|
+module F :
+  functor (X : sig  end) ->
+    sig module N : sig val x : int end module N' = N end
+module G : functor (X : sig  end) -> sig module N' : sig val x : int end end
+module M5 : sig module N' : sig val x : int end end
+- : int = 1
+|}];;
 
 module M = struct
   module D = struct let y = 3 end
@@ -59,6 +158,19 @@ M2.N'.x;;
 
 open M;;
 N'.x;;
+[%%expect{|
+module M :
+  sig
+    module D : sig val y : int end
+    module N : sig val x : int end
+    module N' = N
+  end
+module M1 : sig module N : sig val x : int end module N' = N end
+- : int = 1
+module M2 : sig module N' : sig val x : int end end
+- : int = 1
+- : int = 1
+|}];;
 
 module M = struct
   module C = Char
@@ -71,12 +183,28 @@ M1.C'.escaped 'A';;
 module M2 : sig module C' : sig val chr : int -> char end end =
   (M : sig module C : sig val chr : int -> char end module C' = C end);;
 M2.C'.chr 66;;
+[%%expect{|
+module M : sig module C = Char module C' = C end
+module M1 :
+  sig module C : sig val escaped : char -> string end module C' = C end
+- : string = "A"
+module M2 : sig module C' : sig val chr : int -> char end end
+- : char = 'B'
+|}];;
 
 StdLabels.List.map;;
+[%%expect{|
+- : f:('a -> 'b) -> 'a list -> 'b list = <fun>
+|}];;
 
 module Q = Queue;;
 exception QE = Q.Empty;;
 try Q.pop (Q.create ()) with QE -> "Ok";;
+[%%expect{|
+module Q = Queue
+exception QE
+- : string = "Ok"
+|}];;
 
 module type Complex = module type of Complex with type t = Complex.t;;
 module M : sig module C : Complex end = struct module C = Complex end;;
@@ -84,14 +212,131 @@ module M : sig module C : Complex end = struct module C = Complex end;;
 module C = Complex;;
 C.one.Complex.re;;
 include C;;
+[%%expect{|
+module type Complex =
+  sig
+    type t = Complex.t = { re : float; im : float; }
+    val zero : t
+    val one : t
+    val i : t
+    val neg : t -> t
+    val conj : t -> t
+    val add : t -> t -> t
+    val sub : t -> t -> t
+    val mul : t -> t -> t
+    val inv : t -> t
+    val div : t -> t -> t
+    val sqrt : t -> t
+    val norm2 : t -> float
+    val norm : t -> float
+    val arg : t -> float
+    val polar : float -> float -> t
+    val exp : t -> t
+    val log : t -> t
+    val pow : t -> t -> t
+  end
+module M : sig module C : Complex end
+module C = Complex
+- : float = 1.
+type t = Complex.t = { re : float; im : float; }
+val zero : t = {re = 0.; im = 0.}
+val one : t = {re = 1.; im = 0.}
+val i : t = {re = 0.; im = 1.}
+val neg : t -> t = <fun>
+val conj : t -> t = <fun>
+val add : t -> t -> t = <fun>
+val sub : t -> t -> t = <fun>
+val mul : t -> t -> t = <fun>
+val inv : t -> t = <fun>
+val div : t -> t -> t = <fun>
+val sqrt : t -> t = <fun>
+val norm2 : t -> float = <fun>
+val norm : t -> float = <fun>
+val arg : t -> float = <fun>
+val polar : float -> float -> t = <fun>
+val exp : t -> t = <fun>
+val log : t -> t = <fun>
+val pow : t -> t -> t = <fun>
+|}];;
 
 module F(X:sig module C = Char end) = struct module C = X.C end;;
+[%%expect{|
+module F : functor (X : sig module C = Char end) -> sig module C = Char end
+|}];;
 
 (* Applicative functors *)
 module S = String
 module StringSet = Set.Make(String)
 module SSet = Set.Make(S);;
 let f (x : StringSet.t) = (x : SSet.t);;
+[%%expect{|
+module S = String
+module StringSet :
+  sig
+    type elt = String.t
+    type t = Set.Make(String).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val max_elt : t -> elt
+    val choose : t -> elt
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val of_list : elt list -> t
+  end
+module SSet :
+  sig
+    type elt = S.t
+    type t = Set.Make(S).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val max_elt : t -> elt
+    val choose : t -> elt
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val of_list : elt list -> t
+  end
+val f : StringSet.t -> SSet.t = <fun>
+|}];;
 
 (* Also using include (cf. Leo's mail 2013-11-16) *)
 module F (M : sig end) : sig type t end = struct type t = int end
@@ -101,6 +346,13 @@ module T = struct
 end;;
 include T;;
 let f (x : t) : T.t = x ;;
+[%%expect{|
+module F : functor (M : sig  end) -> sig type t end
+module T : sig module M : sig  end type t = F(M).t end
+module M = T.M
+type t = F(M).t
+val f : t -> T.t = <fun>
+|}];;
 
 (* PR#4049 *)
 (* This works thanks to abbreviations *)
@@ -111,6 +363,47 @@ module A = struct
 end
 module A1 = A;;
 A1.empty = A.empty;;
+[%%expect{|
+module A :
+  sig
+    module B : sig type t val compare : 'a -> 'b -> int end
+    module S :
+      sig
+        type elt = B.t
+        type t = Set.Make(B).t
+        val empty : t
+        val is_empty : t -> bool
+        val mem : elt -> t -> bool
+        val add : elt -> t -> t
+        val singleton : elt -> t
+        val remove : elt -> t -> t
+        val union : t -> t -> t
+        val inter : t -> t -> t
+        val diff : t -> t -> t
+        val compare : t -> t -> int
+        val equal : t -> t -> bool
+        val subset : t -> t -> bool
+        val iter : (elt -> unit) -> t -> unit
+        val map : (elt -> elt) -> t -> t
+        val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+        val for_all : (elt -> bool) -> t -> bool
+        val exists : (elt -> bool) -> t -> bool
+        val filter : (elt -> bool) -> t -> t
+        val partition : (elt -> bool) -> t -> t * t
+        val cardinal : t -> int
+        val elements : t -> elt list
+        val min_elt : t -> elt
+        val max_elt : t -> elt
+        val choose : t -> elt
+        val split : elt -> t -> t * bool * t
+        val find : elt -> t -> elt
+        val of_list : elt list -> t
+      end
+    val empty : S.t
+  end
+module A1 = A
+- : bool = true
+|}];;
 
 (* PR#3476 *)
 (* Does not work yet *)
@@ -125,6 +418,18 @@ module F (Y : sig type t end) (M : sig type t = Y.t end) = struct end;;
 module G = F (M.Y);;
 (*module N = G (M);;
 module N = F (M.Y) (M);;*)
+[%%expect{|
+module FF : functor (X : sig  end) -> sig type t end
+module M :
+  sig
+    module X : sig  end
+    module Y : sig type t = FF(X).t end
+    type t = Y.t
+  end
+module F :
+  functor (Y : sig type t end) (M : sig type t = Y.t end) -> sig  end
+module G : functor (M : sig type t = M.Y.t end) -> sig  end
+|}];;
 
 (* PR#6307 *)
 
@@ -137,6 +442,15 @@ module F (L : (module type of L1)) = struct end;;
 
 module F1 = F(L1);; (* ok *)
 module F2 = F(L2);; (* should succeed too *)
+[%%expect{|
+module A1 : sig  end
+module A2 : sig  end
+module L1 : sig module X = A1 end
+module L2 : sig module X = A2 end
+module F : functor (L : sig module X : sig  end end) -> sig  end
+module F1 : sig  end
+module F2 : sig  end
+|}];;
 
 (* Counter example: why we need to be careful with PR#6307 *)
 module Int = struct type t = int let compare = compare end
@@ -155,6 +469,58 @@ module type S' = sig
   module I = Int2
   include S with module I := I
 end;; (* fail *)
+[%%expect{|
+module Int : sig type t = int val compare : 'a -> 'a -> int end
+module SInt :
+  sig
+    type elt = Int.t
+    type t = Set.Make(Int).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val map : (elt -> elt) -> t -> t
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val max_elt : t -> elt
+    val choose : t -> elt
+    val split : elt -> t -> t * bool * t
+    val find : elt -> t -> elt
+    val of_list : elt list -> t
+  end
+type (_, _) eq = Eq : ('a, 'a) eq
+type wrap = W of (SInt.t, SInt.t) eq
+module M :
+  sig
+    module I = Int
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+  end
+module type S =
+  sig
+    module I = Int
+    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
+  end
+module Int2 : sig type t = int val compare : 'a -> 'a -> int end
+Line _, characters 10-30:
+Error: In this `with' constraint, the new definition of I
+       does not match its original definition in the constrained signature:
+       Modules do not match: (module Int2) is not included in (module Int)
+|}];;
 
 (* (* if the above succeeded, one could break invariants *)
 module rec M2 : S' = M2;; (* should succeed! (but this is bad) *)
@@ -178,6 +544,22 @@ module M = struct
   end
 end;;
 module type S = module type of M ;;
+[%%expect{|
+module M :
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
+  end
+module type S =
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
+  end
+|}];;
 
 module M = struct
   module N = struct module I = Int end
@@ -187,18 +569,57 @@ module M = struct
   end
 end;;
 module type S = module type of M ;;
+[%%expect{|
+module M :
+  sig
+    module N : sig module I = Int end
+    module P : sig module I = N.I end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
+  end
+module type S =
+  sig
+    module N : sig module I = Int end
+    module P :
+      sig module I : sig type t = int val compare : 'a -> 'a -> int end end
+    module Q :
+      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
+  end
+|}];;
 
 (* PR#6365 *)
 module type S = sig module M : sig type t val x : t end end;;
 module H = struct type t = A let x = A end;;
 module H' = H;;
 module type S' = S with module M = H';; (* shouldn't introduce an alias *)
+[%%expect{|
+module type S = sig module M : sig type t val x : t end end
+module H : sig type t = A val x : t end
+module H' = H
+module type S' = sig module M : sig type t = H.t = A val x : t end end
+|}];;
 
 (* PR#6376 *)
 module type Alias = sig module N : sig end module M = N end;;
 module F (X : sig end) = struct type t end;;
 module type A = Alias with module N := F(List);;
 module rec Bad : A = Bad;;
+[%%expect{|
+module type Alias = sig module N : sig  end module M = N end
+module F : functor (X : sig  end) -> sig type t end
+Line _:
+Error: Module type declarations do not match:
+         module type A = sig module M = F(List) end
+       does not match
+         module type A = sig module M = F(List) end
+       At position module type A = <here>
+       Modules do not match:
+         sig module M = F(List) end
+       is not included in
+         sig module M = F(List) end
+       At position module type A = sig module M : <here> end
+       Module F(List) cannot be aliased
+|}];;
 
 (* Shinwell 2014-04-23 *)
 module B = struct
@@ -215,17 +636,30 @@ module K = struct
 end;;
 
 let x : K.N.t = "foo";;
+[%%expect{|
+module B : sig module R : sig type t = string end module O = R end
+module K : sig module E = B module N = E.O end
+val x : K.N.t = "foo"
+|}];;
 
 (* PR#6465 *)
 
 module M = struct type t = A module B = struct type u = B end end;;
-module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *)
+module P : sig type t = M.t = A module B = M.B end = M;;
 module P : sig type t = M.t = A module B = M.B end = struct include M end;;
+[%%expect{|
+module M : sig type t = A module B : sig type u = B end end
+module P : sig type t = M.t = A module B = M.B end
+module P : sig type t = M.t = A module B = M.B end
+|}];;
 
 module type S = sig
   module M : sig module P : sig end end
   module Q = M
 end;;
+[%%expect{|
+module type S = sig module M : sig module P : sig  end end module Q = M end
+|}];;
 module type S = sig
   module M : sig module N : sig end module P : sig end end
   module Q : sig module N = M.N module P = M.P end
@@ -234,7 +668,40 @@ module R = struct
   module M = struct module N = struct end module P = struct end end
   module Q = M
 end;;
-module R' : S = R;; (* should be ok *)
+module R' : S = R;;
+[%%expect{|
+module type S =
+  sig
+    module M : sig module N : sig  end module P : sig  end end
+    module Q : sig module N = M.N module P = M.P end
+  end
+module R :
+  sig
+    module M : sig module N : sig  end module P : sig  end end
+    module Q = M
+  end
+module R' : S
+|}];;
+
+module F (X : sig end) = struct type t end;;
+module M : sig
+  type a
+  module Foo : sig
+    module Bar : sig end
+    type b = a
+  end
+end = struct
+  module Foo = struct
+    module Bar = struct end
+    type b = F(Bar).t
+  end
+  type a = Foo.b
+end;;
+[%%expect{|
+module F : functor (X : sig  end) -> sig type t end
+module M :
+  sig type a module Foo : sig module Bar : sig  end type b = a end end
+|}];;
 
 (* PR#6578 *)
 
@@ -242,5 +709,14 @@ module M = struct let f x = x end
 module rec R : sig module M : sig val f : 'a -> 'a end end =
   struct module M = M end;;
 R.M.f 3;;
+[%%expect{|
+module M : sig val f : 'a -> 'a end
+module rec R : sig module M : sig val f : 'a -> 'a end end
+- : int = 3
+|}];;
 module rec R : sig module M = M end = struct module M = M end;;
 R.M.f 3;;
+[%%expect{|
+module rec R : sig module M = M end
+- : int = 3
+|}];;

diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference
deleted file mode 100644 (file)
index 724f013..0000000
--- a/testsuite/tests/typing-modules/aliases.ml.reference
+++ /dev/null
@@ -1,402 +0,0 @@
-
-# module C = Char
-# - : char = 'B'
-#   module C' :
-  sig
-    external code : char -> int = "%identity"
-    val chr : int -> char
-    val escaped : char -> string
-    val lowercase : char -> char
-    val uppercase : char -> char
-    val lowercase_ascii : char -> char
-    val uppercase_ascii : char -> char
-    type t = char
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    external unsafe_chr : int -> char = "%identity"
-  end
-# - : char = 'B'
-#   module C3 :
-  sig
-    external code : char -> int = "%identity"
-    val chr : int -> char
-    val escaped : char -> string
-    val lowercase : char -> char
-    val uppercase : char -> char
-    val lowercase_ascii : char -> char
-    val uppercase_ascii : char -> char
-    type t = char
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    external unsafe_chr : int -> char = "%identity"
-  end
-# - : char = 'B'
-#   val f : 'a list -> int = <fun>
-# val g : int list -> int = <fun>
-#   module F :
-  functor (X : sig  end) ->
-    sig
-      external code : char -> int = "%identity"
-      val chr : int -> char
-      val escaped : char -> string
-      val lowercase : char -> char
-      val uppercase : char -> char
-      val lowercase_ascii : char -> char
-      val uppercase_ascii : char -> char
-      type t = char
-      val compare : t -> t -> int
-      val equal : t -> t -> bool
-      external unsafe_chr : int -> char = "%identity"
-    end
-# module C4 :
-  sig
-    external code : char -> int = "%identity"
-    val chr : int -> char
-    val escaped : char -> string
-    val lowercase : char -> char
-    val uppercase : char -> char
-    val lowercase_ascii : char -> char
-    val uppercase_ascii : char -> char
-    type t = char
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    external unsafe_chr : int -> char = "%identity"
-  end
-# - : char = 'B'
-#   module G : functor (X : sig  end) -> sig module M : sig  end end
-# module M : sig module M : sig  end end
-#         module M' : sig module N : sig val x : int end module N' = N end
-# - : int = 1
-#   module M'' : sig module N' : sig val x : int end end
-# - : int = 1
-# module M2 : sig module N = M'.N module N' = M'.N' end
-# module M3 : sig module N' : sig val x : int end end
-# - : int = 1
-# module M3' : sig module N' : sig val x : int end end
-# - : int = 1
-#         module M4 : sig module N' : sig val x : int end end
-# - : int = 1
-#         module F :
-  functor (X : sig  end) ->
-    sig module N : sig val x : int end module N' = N end
-# module G : functor (X : sig  end) -> sig module N' : sig val x : int end end
-# module M5 : sig module N' : sig val x : int end end
-# - : int = 1
-#           module M :
-  sig
-    module D : sig val y : int end
-    module N : sig val x : int end
-    module N' = N
-  end
-#   module M1 : sig module N : sig val x : int end module N' = N end
-# - : int = 1
-#   module M2 : sig module N' : sig val x : int end end
-# - : int = 1
-#   # - : int = 1
-#         module M : sig module C = Char module C' = C end
-#     module M1 :
-  sig module C : sig val escaped : char -> string end module C' = C end
-# - : string = "A"
-#   module M2 : sig module C' : sig val chr : int -> char end end
-# - : char = 'B'
-#   - : f:('a -> 'b) -> 'a list -> 'b list = <fun>
-#   module Q = Queue
-# exception QE
-# - : string = "Ok"
-#   module type Complex =
-  sig
-    type t = Complex.t = { re : float; im : float; }
-    val zero : t
-    val one : t
-    val i : t
-    val neg : t -> t
-    val conj : t -> t
-    val add : t -> t -> t
-    val sub : t -> t -> t
-    val mul : t -> t -> t
-    val inv : t -> t
-    val div : t -> t -> t
-    val sqrt : t -> t
-    val norm2 : t -> float
-    val norm : t -> float
-    val arg : t -> float
-    val polar : float -> float -> t
-    val exp : t -> t
-    val log : t -> t
-    val pow : t -> t -> t
-  end
-# module M : sig module C : Complex end
-#   module C = Complex
-# - : float = 1.
-# type t = Complex.t = { re : float; im : float; }
-val zero : t = {re = 0.; im = 0.}
-val one : t = {re = 1.; im = 0.}
-val i : t = {re = 0.; im = 1.}
-val neg : t -> t = <fun>
-val conj : t -> t = <fun>
-val add : t -> t -> t = <fun>
-val sub : t -> t -> t = <fun>
-val mul : t -> t -> t = <fun>
-val inv : t -> t = <fun>
-val div : t -> t -> t = <fun>
-val sqrt : t -> t = <fun>
-val norm2 : t -> float = <fun>
-val norm : t -> float = <fun>
-val arg : t -> float = <fun>
-val polar : float -> float -> t = <fun>
-val exp : t -> t = <fun>
-val log : t -> t = <fun>
-val pow : t -> t -> t = <fun>
-#   module F : functor (X : sig module C = Char end) -> sig module C = Char end
-#         module S = String
-module StringSet :
-  sig
-    type elt = String.t
-    type t = Set.Make(String).t
-    val empty : t
-    val is_empty : t -> bool
-    val mem : elt -> t -> bool
-    val add : elt -> t -> t
-    val singleton : elt -> t
-    val remove : elt -> t -> t
-    val union : t -> t -> t
-    val inter : t -> t -> t
-    val diff : t -> t -> t
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    val subset : t -> t -> bool
-    val iter : (elt -> unit) -> t -> unit
-    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    val for_all : (elt -> bool) -> t -> bool
-    val exists : (elt -> bool) -> t -> bool
-    val filter : (elt -> bool) -> t -> t
-    val partition : (elt -> bool) -> t -> t * t
-    val cardinal : t -> int
-    val elements : t -> elt list
-    val min_elt : t -> elt
-    val max_elt : t -> elt
-    val choose : t -> elt
-    val split : elt -> t -> t * bool * t
-    val find : elt -> t -> elt
-    val of_list : elt list -> t
-  end
-module SSet :
-  sig
-    type elt = S.t
-    type t = Set.Make(S).t
-    val empty : t
-    val is_empty : t -> bool
-    val mem : elt -> t -> bool
-    val add : elt -> t -> t
-    val singleton : elt -> t
-    val remove : elt -> t -> t
-    val union : t -> t -> t
-    val inter : t -> t -> t
-    val diff : t -> t -> t
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    val subset : t -> t -> bool
-    val iter : (elt -> unit) -> t -> unit
-    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    val for_all : (elt -> bool) -> t -> bool
-    val exists : (elt -> bool) -> t -> bool
-    val filter : (elt -> bool) -> t -> t
-    val partition : (elt -> bool) -> t -> t * t
-    val cardinal : t -> int
-    val elements : t -> elt list
-    val min_elt : t -> elt
-    val max_elt : t -> elt
-    val choose : t -> elt
-    val split : elt -> t -> t * bool * t
-    val find : elt -> t -> elt
-    val of_list : elt list -> t
-  end
-# val f : StringSet.t -> SSet.t = <fun>
-#             module F : functor (M : sig  end) -> sig type t end
-module T : sig module M : sig  end type t = F(M).t end
-# module M = T.M
-type t = F(M).t
-# val f : t -> T.t = <fun>
-#                 module A :
-  sig
-    module B : sig type t val compare : 'a -> 'b -> int end
-    module S :
-      sig
-        type elt = B.t
-        type t = Set.Make(B).t
-        val empty : t
-        val is_empty : t -> bool
-        val mem : elt -> t -> bool
-        val add : elt -> t -> t
-        val singleton : elt -> t
-        val remove : elt -> t -> t
-        val union : t -> t -> t
-        val inter : t -> t -> t
-        val diff : t -> t -> t
-        val compare : t -> t -> int
-        val equal : t -> t -> bool
-        val subset : t -> t -> bool
-        val iter : (elt -> unit) -> t -> unit
-        val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-        val for_all : (elt -> bool) -> t -> bool
-        val exists : (elt -> bool) -> t -> bool
-        val filter : (elt -> bool) -> t -> t
-        val partition : (elt -> bool) -> t -> t * t
-        val cardinal : t -> int
-        val elements : t -> elt list
-        val min_elt : t -> elt
-        val max_elt : t -> elt
-        val choose : t -> elt
-        val split : elt -> t -> t * bool * t
-        val find : elt -> t -> elt
-        val of_list : elt list -> t
-      end
-    val empty : S.t
-  end
-module A1 = A
-# - : bool = true
-#                   module FF : functor (X : sig  end) -> sig type t end
-module M :
-  sig
-    module X : sig  end
-    module Y : sig type t = FF(X).t end
-    type t = Y.t
-  end
-module F :
-  functor (Y : sig type t end) (M : sig type t = Y.t end) -> sig  end
-#   module G : functor (M : sig type t = M.Y.t end) -> sig  end
-# *               module A1 : sig  end
-module A2 : sig  end
-module L1 : sig module X = A1 end
-module L2 : sig module X = A2 end
-#   module F : functor (L : sig module X : sig  end end) -> sig  end
-#   module F1 : sig  end
-# module F2 : sig  end
-#                     module Int : sig type t = int val compare : 'a -> 'a -> int end
-module SInt :
-  sig
-    type elt = Int.t
-    type t = Set.Make(Int).t
-    val empty : t
-    val is_empty : t -> bool
-    val mem : elt -> t -> bool
-    val add : elt -> t -> t
-    val singleton : elt -> t
-    val remove : elt -> t -> t
-    val union : t -> t -> t
-    val inter : t -> t -> t
-    val diff : t -> t -> t
-    val compare : t -> t -> int
-    val equal : t -> t -> bool
-    val subset : t -> t -> bool
-    val iter : (elt -> unit) -> t -> unit
-    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
-    val for_all : (elt -> bool) -> t -> bool
-    val exists : (elt -> bool) -> t -> bool
-    val filter : (elt -> bool) -> t -> t
-    val partition : (elt -> bool) -> t -> t * t
-    val cardinal : t -> int
-    val elements : t -> elt list
-    val min_elt : t -> elt
-    val max_elt : t -> elt
-    val choose : t -> elt
-    val split : elt -> t -> t * bool * t
-    val find : elt -> t -> elt
-    val of_list : elt list -> t
-  end
-type (_, _) eq = Eq : ('a, 'a) eq
-type wrap = W of (SInt.t, SInt.t) eq
-module M :
-  sig
-    module I = Int
-    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
-  end
-# module type S =
-  sig
-    module I = Int
-    type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(I).t) eq
-  end
-#   module Int2 : sig type t = int val compare : 'a -> 'a -> int end
-#       Characters 49-69:
-    include S with module I := I
-            ^^^^^^^^^^^^^^^^^^^^
-Error: In this `with' constraint, the new definition of I
-       does not match its original definition in the constrained signature:
-       Modules do not match: (module Int2) is not included in (module Int)
-#   * * * * * * * * * * *                   module M :
-  sig
-    module N : sig module I = Int end
-    module P : sig module I = N.I end
-    module Q :
-      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
-  end
-# module type S =
-  sig
-    module N : sig module I = Int end
-    module P : sig module I = N.I end
-    module Q :
-      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(P.I).t) eq end
-  end
-#               module M :
-  sig
-    module N : sig module I = Int end
-    module P : sig module I = N.I end
-    module Q :
-      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
-  end
-# module type S =
-  sig
-    module N : sig module I = Int end
-    module P :
-      sig module I : sig type t = int val compare : 'a -> 'a -> int end end
-    module Q :
-      sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end
-  end
-#     module type S = sig module M : sig type t val x : t end end
-# module H : sig type t = A val x : t end
-# module H' = H
-# module type S' = sig module M : sig type t = H.t = A val x : t end end
-#     module type Alias = sig module N : sig  end module M = N end
-# module F : functor (X : sig  end) -> sig type t end
-# Characters -1--1:
-  module type A = Alias with module N := F(List);;
-  
-Error: Module type declarations do not match:
-         module type A = sig module M = F(List) end
-       does not match
-         module type A = sig module M = F(List) end
-       At position module type A = <here>
-       Modules do not match:
-         sig module M = F(List) end
-       is not included in
-         sig module M = F(List) end
-       At position module type A = sig module M : <here> end
-       Module F(List) cannot be aliased
-# Characters 17-18:
-  module rec Bad : A = Bad;;
-                   ^
-Error: Unbound module type A
-#                           module B : sig module R : sig type t = string end module O = R end
-module K : sig module E = B module N = E.O end
-#   val x : K.N.t = "foo"
-#       module M : sig type t = A module B : sig type u = B end end
-# module P : sig type t = M.t = A module B = M.B end
-# module P : sig type t = M.t = A module B = M.B end
-#         module type S = sig module M : sig module P : sig  end end module Q = M end
-#       module type S =
-  sig
-    module M : sig module N : sig  end module P : sig  end end
-    module Q : sig module N = M.N module P = M.P end
-  end
-#       module R :
-  sig
-    module M : sig module N : sig  end module P : sig  end end
-    module Q = M
-  end
-# module R' : S
-#           module M : sig val f : 'a -> 'a end
-module rec R : sig module M : sig val f : 'a -> 'a end end
-# - : int = 3
-# module rec R : sig module M = M end
-# - : int = 3
-# 

diff --git a/testsuite/tests/typing-modules/b.ml b/testsuite/tests/typing-modules/b.ml
deleted file mode 100644 (file)
index 4c43e80..0000000
--- a/testsuite/tests/typing-modules/b.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-open A
-let f =
-  L.map S.capitalize
-
-let () =
-  L.iter print_endline (f ["jacques"; "garrigue"])
-
-module C : sig module L : module type of List end = struct include A end
-
-(* The following introduces a (useless) dependency on A:
-module C : sig module L : module type of List end = A
-*)
-
-include D'
-(*
-let () =
-  print_endline (string_of_int D'.M.y)
-*)

diff --git a/testsuite/tests/typing-modules/b.ml.reference b/testsuite/tests/typing-modules/b.ml.reference
deleted file mode 100644 (file)
index 9faafbf..0000000
--- a/testsuite/tests/typing-modules/b.ml.reference
+++ /dev/null
@@ -1,5 +0,0 @@
-
-#                   * *       * * *   
-Characters 352-352:
-  Error: Syntax error
-# 

diff --git a/testsuite/tests/typing-modules/b2.ml b/testsuite/tests/typing-modules/b2.ml
deleted file mode 100644 (file)
index 034e432..0000000
--- a/testsuite/tests/typing-modules/b2.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-open A
-let f =
-  L.map S.capitalize
-
-let () =
-  L.iter print_endline (f ["jacques"; "garrigue"])
-
-module C : sig module L : module type of List end = struct include A end
-
-(* The following introduces a (useless) dependency on A:
-module C : sig module L : module type of List end = A
-*)
-
-(* No dependency on D *)

diff --git a/testsuite/tests/typing-modules/b2.ml.reference b/testsuite/tests/typing-modules/b2.ml.reference
deleted file mode 100644 (file)
index 9b45586..0000000
--- a/testsuite/tests/typing-modules/b2.ml.reference
+++ /dev/null
@@ -1,5 +0,0 @@
-
-#                   * *       
-Characters 312-312:
-  Error: Syntax error
-# 

diff --git a/testsuite/tests/typing-modules/b3.mli b/testsuite/tests/typing-modules/b3.mli
deleted file mode 100644 (file)
index 04599ab..0000000
--- a/testsuite/tests/typing-modules/b3.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-open A
-(*module type S = module type of D'.M*)
-type t = Complex.t
-type s = String.t

diff --git a/testsuite/tests/typing-modules/d.ml b/testsuite/tests/typing-modules/d.ml
deleted file mode 100644 (file)
index 55d311f..0000000
--- a/testsuite/tests/typing-modules/d.ml
+++ /dev/null
@@ -1,2 +0,0 @@
-let x = 3
-module M = struct let y = 5 end

diff --git a/testsuite/tests/typing-modules/d.ml.reference b/testsuite/tests/typing-modules/d.ml.reference
deleted file mode 100644 (file)
index 06308c7..0000000
--- a/testsuite/tests/typing-modules/d.ml.reference
+++ /dev/null
@@ -1,5 +0,0 @@
-
-#     
-Characters 42-42:
-  Error: Syntax error
-# 

diff --git a/testsuite/tests/typing-modules/firstclass.ml b/testsuite/tests/typing-modules/firstclass.ml
index b778443a8d8ded9e3ad4300e99c626a5c7c3870d..8bf0e422bf4061da5b00154073aaf48a7fcc0ac7 100644 (file)
--- a/testsuite/tests/typing-modules/firstclass.ml
+++ b/testsuite/tests/typing-modules/firstclass.ml
@@ -5,6 +5,12 @@ module type S' = sig type t = int type u = bool end;;
    are inferred *)
 let f (x : (module S with type t = 'a and type u = 'b)) = (x : (module S'));;
 let g x = (x : (module S with type t = 'a and type u = 'b) :> (module S'));;
+[%%expect{|
+module type S = sig type u type t end
+module type S' = sig type t = int type u = bool end
+val f : (module S with type t = int and type u = bool) -> (module S') = <fun>
+val g : (module S with type t = int and type u = bool) -> (module S') = <fun>
+|}];;
 
 (* with subtyping it is also ok to forget some types *)
 module type S2 = sig type u type t type w end;;
@@ -14,8 +20,24 @@ let f2 (x : (module S2 with type t = 'a and type u = 'b)) =
   (x : (module S'));; (* fail *)
 let k (x : (module S2 with type t = 'a)) =
   (x : (module S with type t = 'a));; (* fail *)
+[%%expect{|
+module type S2 = sig type u type t type w end
+val g2 : (module S2 with type t = int and type u = bool) -> (module S') =
+  <fun>
+val h : (module S2 with type t = 'a) -> (module S with type t = 'a) = <fun>
+Line _, characters 3-4:
+Error: This expression has type
+         (module S2 with type t = int and type u = bool)
+       but an expression was expected of type (module S')
+|}];;
 
 (* but you cannot forget values (no physical coercions) *)
 module type S3 = sig type u type t val x : int end;;
 let g3 x =
   (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
+[%%expect{|
+module type S3 = sig type u type t val x : int end
+Line _, characters 2-67:
+Error: Type (module S3 with type t = int and type u = bool)
+       is not a subtype of (module S')
+|}];;

diff --git a/testsuite/tests/typing-modules/firstclass.ml.reference b/testsuite/tests/typing-modules/firstclass.ml.reference
deleted file mode 100644 (file)
index db37600..0000000
--- a/testsuite/tests/typing-modules/firstclass.ml.reference
+++ /dev/null
@@ -1,27 +0,0 @@
-
-# module type S = sig type u type t end
-# module type S' = sig type t = int type u = bool end
-#   *   val f : (module S with type t = int and type u = bool) -> (module S') = <fun>
-# val g : (module S with type t = int and type u = bool) -> (module S') = <fun>
-#     module type S2 = sig type u type t type w end
-# val g2 : (module S2 with type t = int and type u = bool) -> (module S') =
-  <fun>
-# val h : (module S2 with type t = 'a) -> (module S with type t = 'a) = <fun>
-#   Characters 63-64:
-    (x : (module S'));; (* fail *)
-     ^
-Error: This expression has type
-         (module S2 with type t = int and type u = bool)
-       but an expression was expected of type (module S')
-#   Characters 46-47:
-    (x : (module S with type t = 'a));; (* fail *)
-     ^
-Error: This expression has type (module S2 with type t = 'a)
-       but an expression was expected of type (module S with type t = 'a)
-#     module type S3 = sig type u type t val x : int end
-#   Characters 13-78:
-    (x : (module S3 with type t = 'a and type u = 'b) :> (module S'));; (* fail *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type (module S3 with type t = int and type u = bool)
-       is not a subtype of (module S') 
-# 

diff --git a/testsuite/tests/typing-modules/generative.ml b/testsuite/tests/typing-modules/generative.ml
index dc5bf52898675e182773d4cd663aaa38f4e7d41a..0fb231509bad4d90c7468e17d2121208d4f8f48f 100644 (file)
--- a/testsuite/tests/typing-modules/generative.ml
+++ b/testsuite/tests/typing-modules/generative.ml
@@ -6,24 +6,70 @@ let v = (module struct let x = 3 end : S);;
 module F() = (val v);; (* ok *)
 module G (X : sig end) : S = F ();; (* ok *)
 module H (X : sig end) = (val v);; (* ok *)
+[%%expect{|
+module type S = sig val x : int end
+val v : (module S) = <module>
+module F : functor () -> S
+module G : functor (X : sig  end) -> S
+module H : functor (X : sig  end) -> S
+|}];;
 
 (* With type *)
 module type S = sig type t val x : t end;;
 let v = (module struct type t = int let x = 3 end : S);;
 module F() = (val v);; (* ok *)
+[%%expect{|
+module type S = sig type t val x : t end
+val v : (module S) = <module>
+module F : functor () -> S
+|}];;
 module G (X : sig end) : S = F ();; (* fail *)
+[%%expect{|
+Line _, characters 29-33:
+Error: This expression creates fresh types.
+       It is not allowed inside applicative functors.
+|}];;
 module H() = F();; (* ok *)
+[%%expect{|
+module H : functor () -> S
+|}];;
 
 (* Alias *)
 module U = struct end;;
 module M = F(struct end);; (* ok *)
+[%%expect{|
+module U : sig  end
+module M : S
+|}];;
 module M = F(U);; (* fail *)
+[%%expect{|
+Line _, characters 11-12:
+Error: This is a generative functor. It can only be applied to ()
+|}];;
 
 (* Cannot coerce between applicative and generative *)
 module F1 (X : sig end) = struct end;;
 module F2 : functor () -> sig end = F1;; (* fail *)
+[%%expect{|
+module F1 : functor (X : sig  end) -> sig  end
+Line _, characters 36-38:
+Error: Signature mismatch:
+       Modules do not match:
+         functor (X : sig  end) -> sig  end
+       is not included in
+         functor () -> sig  end
+|}];;
 module F3 () = struct end;;
 module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
+[%%expect{|
+module F3 : functor () -> sig  end
+Line _, characters 47-49:
+Error: Signature mismatch:
+       Modules do not match:
+         functor () -> sig  end
+       is not included in
+         functor (X : sig  end) -> sig  end
+|}];;
 
 (* tests for shortened functor notation () *)
 module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;;
@@ -32,3 +78,9 @@ module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) ->
 module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;;
 module GZ : functor (X: sig end) () (Z: sig end) -> sig end
           = functor (X: sig end) () (Z: sig end) -> struct end;;
+[%%expect{|
+module X : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
+module Y : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
+module Z : sig  end -> sig  end -> sig  end -> sig  end
+module GZ : functor (X : sig  end) () (Z : sig  end) -> sig  end
+|}];;

diff --git a/testsuite/tests/typing-modules/generative.ml.reference b/testsuite/tests/typing-modules/generative.ml.reference
deleted file mode 100644 (file)
index 0f892d4..0000000
--- a/testsuite/tests/typing-modules/generative.ml.reference
+++ /dev/null
@@ -1,44 +0,0 @@
-
-#       module type S = sig val x : int end
-# val v : (module S) = <module>
-# module F : functor () -> S
-# module G : functor (X : sig  end) -> S
-# module H : functor (X : sig  end) -> S
-#     module type S = sig type t val x : t end
-# val v : (module S) = <module>
-# module F : functor () -> S
-# Characters 29-33:
-  module G (X : sig end) : S = F ();; (* fail *)
-                               ^^^^
-Error: This expression creates fresh types.
-       It is not allowed inside applicative functors.
-# module H : functor () -> S
-#     module U : sig  end
-# module M : S
-# Characters 11-12:
-  module M = F(U);; (* fail *)
-             ^
-Error: This is a generative functor. It can only be applied to ()
-#     module F1 : functor (X : sig  end) -> sig  end
-# Characters 36-38:
-  module F2 : functor () -> sig end = F1;; (* fail *)
-                                      ^^
-Error: Signature mismatch:
-       Modules do not match:
-         functor (X : sig  end) -> sig  end
-       is not included in
-         functor () -> sig  end
-# module F3 : functor () -> sig  end
-# Characters 47-49:
-  module F4 : functor (X : sig end) -> sig end = F3;; (* fail *)
-                                                 ^^
-Error: Signature mismatch:
-       Modules do not match:
-         functor () -> sig  end
-       is not included in
-         functor (X : sig  end) -> sig  end
-#     module X : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
-#   module Y : functor (X : sig  end) (Y : sig  end) (Z : sig  end) -> sig  end
-# module Z : sig  end -> sig  end -> sig  end -> sig  end
-#   module GZ : functor (X : sig  end) () (Z : sig  end) -> sig  end
-# 

diff --git a/testsuite/tests/typing-modules/pr5911.ml b/testsuite/tests/typing-modules/pr5911.ml
index 1fa991f1797bcdbc59920fe7b3237e461a1da690..e6f735390c2a9f6f7abebd47fbc57409c939319c 100644 (file)
--- a/testsuite/tests/typing-modules/pr5911.ml
+++ b/testsuite/tests/typing-modules/pr5911.ml
@@ -6,9 +6,19 @@ end;;
 module Good (X : S with type t := unit) = struct
  let () = X.x
 end;;
+[%%expect{|
+module type S = sig type t val x : t end
+module Good : functor (X : sig val x : unit end) -> sig  end
+|}];;
 
 module type T = sig module M : S end;;
 
-module Bad (X : T with type M.t := unit) = struct
+module Bad (X : T with type M.t = unit) = struct
  let () = X.M.x
 end;;
+[%%expect{|
+module type T = sig module M : S end
+module Bad :
+  functor (X : sig module M : sig type t = unit val x : t end end) ->
+    sig  end
+|}];;

diff --git a/testsuite/tests/typing-modules/pr5911.ml.reference b/testsuite/tests/typing-modules/pr5911.ml.reference
deleted file mode 100644 (file)
index e5357b8..0000000
--- a/testsuite/tests/typing-modules/pr5911.ml.reference
+++ /dev/null
@@ -1,9 +0,0 @@
-
-#       module type S = sig type t val x : t end
-#       module Good : functor (X : sig val x : unit end) -> sig  end
-#   module type T = sig module M : S end
-#       Characters 33-35:
-  module Bad (X : T with type M.t := unit) = struct
-                                  ^^
-Error: Syntax error
-# 

diff --git a/testsuite/tests/typing-modules/pr7207.ml b/testsuite/tests/typing-modules/pr7207.ml
index c0ac33d54f9c61e37deea7dbcf00771575b77e2c..1968f87ce726efacebeeb3bf4970b65b1856d6ba 100644 (file)
--- a/testsuite/tests/typing-modules/pr7207.ml
+++ b/testsuite/tests/typing-modules/pr7207.ml
@@ -1,2 +1,7 @@
 module F (X : sig end) = struct type t = int end;;
 type t = F(Does_not_exist).t;;
+[%%expect{|
+module F : functor (X : sig  end) -> sig type t = int end
+Line _, characters 9-28:
+Error: Unbound module Does_not_exist
+|}];;

diff --git a/testsuite/tests/typing-modules/pr7207.ml.reference b/testsuite/tests/typing-modules/pr7207.ml.reference
deleted file mode 100644 (file)
index 4fe8e21..0000000
--- a/testsuite/tests/typing-modules/pr7207.ml.reference
+++ /dev/null
@@ -1,7 +0,0 @@
-
-# module F : functor (X : sig  end) -> sig type t = int end
-# Characters 9-28:
-  type t = F(Does_not_exist).t;;
-           ^^^^^^^^^^^^^^^^^^^
-Error: Unbound module Does_not_exist
-# 

diff --git a/testsuite/tests/typing-modules/printing.ml b/testsuite/tests/typing-modules/printing.ml
index 77dd8c70ee429653f0907443eeb9276eac863fd1..1f107b8f56ebd3e53503ea73e959e5d4a30be246 100644 (file)
--- a/testsuite/tests/typing-modules/printing.ml
+++ b/testsuite/tests/typing-modules/printing.ml
@@ -7,8 +7,20 @@ module type S = sig
   end
 end;;
 module F (X : S) = X.M;;
+[%%expect{|
+module type S =
+  sig
+    class type c = object method m : int end
+    module M : sig class type d = c end
+  end
+module F : functor (X : S) -> sig class type d = X.c end
+|}];;
 
 (* PR#6648 *)
 
 module M = struct module N = struct let x = 1 end end;;
 #show_module M;;
+[%%expect{|
+module M : sig module N : sig val x : int end end
+module M : sig module N : sig ... end end
+|}];;

diff --git a/testsuite/tests/typing-modules/printing.ml.reference b/testsuite/tests/typing-modules/printing.ml.reference
deleted file mode 100644 (file)
index c5a9a77..0000000
--- a/testsuite/tests/typing-modules/printing.ml.reference
+++ /dev/null
@@ -1,10 +0,0 @@
-
-#               module type S =
-  sig
-    class type c = object method m : int end
-    module M : sig class type d = c end
-  end
-# module F : functor (X : S) -> sig class type d = X.c end
-#       module M : sig module N : sig val x : int end end
-# module M : sig module N : sig ... end end
-# 

diff --git a/testsuite/tests/typing-modules/recursive.ml b/testsuite/tests/typing-modules/recursive.ml
new file mode 100644 (file)
index 0000000..abf76e0
--- /dev/null
+++ b/testsuite/tests/typing-modules/recursive.ml
@@ -0,0 +1,7 @@
+(* PR#7324 *)
+
+module rec T : sig type t = T.t end = T;;
+[%%expect{|
+Line _, characters 15-35:
+Error: The type abbreviation T.t is cyclic
+|}]

diff --git a/testsuite/tests/typing-multifile/Makefile b/testsuite/tests/typing-multifile/Makefile
new file mode 100644 (file)
index 0000000..a9653bd
--- /dev/null
+++ b/testsuite/tests/typing-multifile/Makefile
@@ -0,0 +1,32 @@
+#**************************************************************************
+#*                                                                        *
+#*                                OCaml                                   *
+#*                                                                        *
+#*                 Xavier Clerc, SED, INRIA Rocquencourt                  *
+#*                                                                        *
+#*   Copyright 2010 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+GENERATED= a.ml b.ml c.ml
+
+default: pr7325
+
+pr7325:
+       @printf " ... testing pr7325:"
+       @echo "type _ t = T" > a.ml
+       @echo "type 'a t = 'a A.t" > b.ml
+       @echo 'external f : unit -> unit B.t = "%identity"' > c.ml
+       @$(OCAMLC) -c a.ml b.ml && rm a.cmi && $(OCAMLC) -c c.ml \
+         && echo " => passed" || echo " => failed"
+
+clean: defaultclean
+       @rm -f $(GENERATED)
+
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-objects-bugs/pr7284_bad.ml b/testsuite/tests/typing-objects-bugs/pr7284_bad.ml
new file mode 100644 (file)
index 0000000..d6ba2ea
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr7284_bad.ml
@@ -0,0 +1,33 @@
+module type S = sig
+
+   type o1 = < bar : int; foo : int >
+   type o2 = private < foo : int; .. >
+
+   type v1 = T of o1
+   type v2 = T of o2
+
+ end
+
+ module M = struct
+
+   type o1 = < bar : int; foo : int >
+   type o2 = o1
+
+   type v1 = T of o1
+   type v2 = v1 = T of o2
+
+ end
+
+ module F(X : S) = struct
+
+   type 'a wit =
+   | V1 : string -> X.v1 wit
+   | V2 : int -> X.v2 wit
+
+   let f : X.v1 wit -> unit = function V1 s -> print_endline s
+
+ end [@@warning "+8"] [@@warnerror "+8"]
+
+ module N = F(M)
+
+ let () = N.f (N.V2 0)

diff --git a/testsuite/tests/typing-objects-bugs/pr7293_ok.ml b/testsuite/tests/typing-objects-bugs/pr7293_ok.ml
new file mode 100644 (file)
index 0000000..6052814
--- /dev/null
+++ b/testsuite/tests/typing-objects-bugs/pr7293_ok.ml
@@ -0,0 +1,11 @@
+type t = T : t
+type s = T
+
+class c = object (self : 'self)
+
+  method foo : s -> 'self = function
+    | T -> self#bar ()
+
+  method bar : unit -> 'self = fun () -> self
+
+end

diff --git a/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml b/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml
index fda0d123ce9ac300436b0d0e6c95c203f87db2eb..0189310eb05d0e95a34c60103bb29248377767f6 100644 (file)
--- a/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml
+++ b/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml
@@ -98,10 +98,10 @@ struct
 (* the internal representation is UCS4 with big endian*)
 (* The most significant digit appears first. *)
 let get_buf s i =
-  let n = Char.code s.[i] in
-  let n = (n lsl 8) lor (Char.code s.[i + 1]) in
-  let n = (n lsl 8) lor (Char.code s.[i + 2]) in
-  let n = (n lsl 8) lor (Char.code s.[i + 3]) in
+  let n = Bytes.get s i |> Char.code in
+  let n = (n lsl 8) lor (Bytes.get s (i + 1) |> Char.code) in
+  let n = (n lsl 8) lor (Bytes.get s (i + 2) |> Char.code) in
+  let n = (n lsl 8) lor (Bytes.get s (i + 3) |> Char.code) in
   UChar.chr_of_uint n
 
 let set_buf s i u =
@@ -130,16 +130,16 @@ class text_raw buf =
     inherit [cursor] ustorage_base
     val contents = buf
     method first = new cursor (self :> text_raw) 0
-    method len = (String.length contents) / 4
+    method len = (Bytes.length contents) / 4
     method get i = get_buf contents (4 * i)
     method nth i = new cursor (self :> text_raw) i
-    method copy = {< contents = String.copy contents >}
+    method copy = {< contents = Bytes.copy contents >}
     method sub pos len =
-      {< contents = String.sub contents (pos * 4) (len * 4) >}
+      {< contents = Bytes.sub contents (pos * 4) (len * 4) >}
     method concat (text : ustorage) =
-      let buf = String.create (String.length contents + 4 * text#len) in
-      String.blit contents 0 buf 0 (String.length contents);
-      init_buf buf (String.length contents) text;
+      let buf = Bytes.create (Bytes.length contents + 4 * text#len) in
+      Bytes.blit contents 0 buf 0 (Bytes.length contents);
+      init_buf buf (Bytes.length contents) text;
       {< contents = buf >}
   end
 and cursor text i =
@@ -161,7 +161,7 @@ class text init = text_raw (make_buf init)
 class string init = string_raw (make_buf init)
 
 let of_string s =
-  let buf = String.make (4 * String.length s) '\000' in
+  let buf = Bytes.make (4 * String.length s) '\000' in
   for i = 0 to String.length s - 1 do
     buf.[4 * i] <- s.[i]
   done;

diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
index c52fe909c35edc1fbd73a5552228a22aa6cb0c0c..b646ade3e7e7f8dd78de505035be39dd05951c0d 100644 (file)
--- a/testsuite/tests/typing-objects/Tests.ml
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -88,7 +88,7 @@ and 'a d = <f : 'a c>;;
 type 'a c = <f : 'a c>
 and 'a d = <f : int c>;;
 type 'a u = < x : 'a>
-and 'a t = 'a t u;;
+and 'a t = 'a t u;; (* fails since 4.04 *)
 type 'a u = 'a
 and 'a t = 'a t u;;
 type 'a u = 'a;;

diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
index d39a70dc3c52fa4ff5167009e1f0e83419d64cf9..c4c595629f396d84a387d2f6e93af5cd1875ef58 100644 (file)
--- a/testsuite/tests/typing-objects/Tests.ml.principal.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -67,8 +67,11 @@ Error: In the definition of d, type int c should be 'a c
 and 'a d = < f : 'a c >
 #   type 'a c = < f : 'a c >
 and 'a d = < f : int c >
-#   type 'a u = < x : 'a >
-and 'a t = 'a t u
+#   Characters 22-39:
+  and 'a t = 'a t u;; (* fails since 4.04 *)
+  ^^^^^^^^^^^^^^^^^
+Error: The definition of t contains a cycle:
+       'a t u
 #   Characters 15-32:
   and 'a t = 'a t u;;
   ^^^^^^^^^^^^^^^^^

diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index d39a70dc3c52fa4ff5167009e1f0e83419d64cf9..c4c595629f396d84a387d2f6e93af5cd1875ef58 100644 (file)
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -67,8 +67,11 @@ Error: In the definition of d, type int c should be 'a c
 and 'a d = < f : 'a c >
 #   type 'a c = < f : 'a c >
 and 'a d = < f : int c >
-#   type 'a u = < x : 'a >
-and 'a t = 'a t u
+#   Characters 22-39:
+  and 'a t = 'a t u;; (* fails since 4.04 *)
+  ^^^^^^^^^^^^^^^^^
+Error: The definition of t contains a cycle:
+       'a t u
 #   Characters 15-32:
   and 'a t = 'a t u;;
   ^^^^^^^^^^^^^^^^^

diff --git a/testsuite/tests/typing-pattern_open/Makefile b/testsuite/tests/typing-pattern_open/Makefile
new file mode 100644 (file)
index 0000000..9625a3f
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-pattern_open/pattern_open.ml b/testsuite/tests/typing-pattern_open/pattern_open.ml
new file mode 100644 (file)
index 0000000..07390ad
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/pattern_open.ml
@@ -0,0 +1,147 @@
+let pp fmt = Printf.printf fmt
+
+type 'a box = B of 'a
+(* Basic tests *)
+module M = struct
+  type c = C
+  type t = {x : c box }
+end
+;;
+module N = struct
+  type d = D
+  let d = D
+  type t = {x: d box}
+end
+open N
+;;
+let f M.{ x=B C } y  = M.C,y
+;;
+let g M.(x) M.(w) = x * w
+;;
+let g = function
+  | M.[] -> []
+  | M.[C] -> M.[C]
+  | _ -> []
+;;
+let h = function
+  | M.[||] -> None
+  | M.[| C |] -> Some M.C
+  | _ -> None
+;;
+let f2 = function
+  | M.( B (B C) ) -> M.C
+;;
+
+;;
+(* () constructor *)
+let M.() = ()
+;;
+(* Pattern open separation*)
+module L = struct
+  type _ c = C : unit c
+  type t = { t : unit c }
+  type r = { r : unit c }
+  let x ()= pp "Wrong value L.x\n"
+end
+;;
+module K = struct
+  type _ c = C : unit c
+  type t = { t : unit c }
+  type r = { r : unit c }
+  let x ()= pp "Right value K.x\n"
+end
+;;
+let () =
+  let test =
+  let open K in
+  function
+  | L.{t}, ({r=C} : K.r)  -> x ()
+  in
+  test (L.{t=C}, K.{r=C})
+;;
+module Exterior = struct
+module Gadt = struct
+module Boolean = struct
+  type t = { b : bool }
+  type wrong = false | true
+  let print () = pp "Wrong function: Exterior.Gadt.Boolean.print\n"
+end
+
+type _ t =
+  | Bool : Boolean.t -> bool t
+  | Int : int -> int t
+  | Eq : 'a t * 'a t -> bool t
+
+let print () = pp "Wrong function: Exterior.Gadt.print\n"
+end
+let print () = pp "Wrong function: Exterior.print\n"
+end
+;;
+let rec eval: type t. t Exterior.Gadt.t -> t = function
+  | Exterior.( Gadt.( Eq (a,b) ) ) -> (eval a) = (eval b)
+  | Exterior.( Gadt.( Bool Boolean.{b} ) ) -> b
+  | Exterior.Gadt.( Int n ) -> n
+let () =
+  let print () = pp "Right function print\n" in
+  let choose (type a):a Exterior.Gadt.t * a Exterior.Gadt.t -> a -> a =
+  fun (a,b) c ->
+  match a, b, c with
+  | Exterior.( Gadt.( Bool Boolean.{b} ), Gadt.Bool _ , _ ) -> print(); true
+  | Exterior.(Gadt.Bool Gadt.Boolean.{b}), _ , true -> print(); true
+  | Exterior.(Gadt.Bool Gadt.Boolean.{b}), _ , false -> print(); b
+  | Exterior.Gadt.( Int n, Int k, 0 ) -> print(); 0
+  | Exterior.( Gadt.(Int n, Gadt.Int k, l) ) -> print(); k+n+l
+  | Exterior.Gadt.( Eq (a,b) ), _,  true -> print(); true
+  | Exterior.(Gadt.( Eq (a,b), _ ,  false )) -> print(); eval a = eval b in
+  let _ =
+    choose Exterior.Gadt.(Bool Boolean.{b=true}, Bool Boolean.{b=false}) false
+  in
+  print ()
+;;
+(* existential type *)
+module Existential = struct
+type printable = E : 'a * ('a -> unit) -> printable
+end
+
+let rec print: Existential.printable -> unit  = function
+  | Existential.( E(x, print) ) -> print x
+;;
+(* Test that constructors and variables introduced in scope inside
+M.(..) are not propagated outside of M.(..) *)
+module S = struct
+type 'a t = Sep : unit t
+type ex = Ex: 'a * 'a -> ex
+let s = Sep
+end
+;;
+let test_separation = function
+  | S.(Sep), (S.(Sep,Sep), Sep) -> ()
+;;
+let test_separation_2 = function
+  | S.(Ex(a,b)), Ex(c,d) -> ()
+;;
+let test_separation_3 = function
+  | S.(Sep) -> s
+;;
+
+(* Testing interaction of local open in pattern and backtracking *)
+module PR6437 = struct
+  module Ctx = struct
+  type ('a, 'b) t =
+    | Nil : (unit, unit) t
+    | Cons : ('a, 'b) t -> ('a * unit, 'b * unit) t
+  end
+
+  module Var = struct
+  type 'a t =
+    | O : ('a * unit) t
+    | S : 'a t -> ('a * unit) t
+  end
+end
+
+let rec f : type g1 g2. (g1, g2) PR6437.Ctx.t * g1 PR6437.Var.t
+  -> g2 PR6437.Var.t = function
+    | PR6437.( Ctx.(Cons g), Var.(O) ) -> PR6437.Var.O
+    | PR6437.( Ctx.(Cons g), Var.(S n) ) -> PR6437.Var.S (f (g, n))
+    | _ -> .
+;;

diff --git a/testsuite/tests/typing-pattern_open/pattern_open.ml.reference b/testsuite/tests/typing-pattern_open/pattern_open.ml.reference
new file mode 100644 (file)
index 0000000..f97b737
--- /dev/null
+++ b/testsuite/tests/typing-pattern_open/pattern_open.ml.reference
@@ -0,0 +1,81 @@
+
+#                 val pp : ('a, out_channel, unit) format -> 'a = <fun>
+type 'a box = B of 'a
+module M : sig type c = C type t = { x : c box; } end
+#             module N : sig type d = D val d : d type t = { x : d box; } end
+#   val f : M.t -> 'a -> M.c * 'a = <fun>
+#   val g : int -> int -> int = <fun>
+#         val g : M.c list -> M.c list = <fun>
+#         val h : M.c array -> M.c option = <fun>
+#     val f2 : M.c box box -> M.c = <fun>
+#   #     #               module L :
+  sig
+    type _ c = C : unit c
+    type t = { t : unit c; }
+    type r = { r : unit c; }
+    val x : unit -> unit
+  end
+#             module K :
+  sig
+    type _ c = C : unit c
+    type t = { t : unit c; }
+    type r = { r : unit c; }
+    val x : unit -> unit
+  end
+#               Right value K.x
+#                                   module Exterior :
+  sig
+    module Gadt :
+      sig
+        module Boolean :
+          sig
+            type t = { b : bool; }
+            type wrong = false | true
+            val print : unit -> unit
+          end
+        type _ t =
+            Bool : Boolean.t -> bool t
+          | Int : int -> int t
+          | Eq : 'a t * 'a t -> bool t
+        val print : unit -> unit
+      end
+    val print : unit -> unit
+  end
+#                                         Right function print
+Right function print
+val eval : 't Exterior.Gadt.t -> 't = <fun>
+#               module Existential :
+  sig type printable = E : 'a * ('a -> unit) -> printable end
+val print : Existential.printable -> unit = <fun>
+# *             module S :
+  sig
+    type 'a t = Sep : unit t
+    type ex = Ex : 'a * 'a -> ex
+    val s : unit t
+  end
+#     Characters 58-61:
+    | S.(Sep), (S.(Sep,Sep), Sep) -> ()
+                             ^^^
+Error: Unbound constructor Sep
+#     Characters 50-52:
+    | S.(Ex(a,b)), Ex(c,d) -> ()
+                   ^^
+Error: Unbound constructor Ex
+#     Characters 48-49:
+    | S.(Sep) -> s
+                 ^
+Error: Unbound value s
+#                                           module PR6437 :
+  sig
+    module Ctx :
+      sig
+        type ('a, 'b) t =
+            Nil : (unit, unit) t
+          | Cons : ('a, 'b) t -> ('a * unit, 'b * unit) t
+      end
+    module Var :
+      sig type 'a t = O : ('a * unit) t | S : 'a t -> ('a * unit) t end
+  end
+val f : ('g1, 'g2) PR6437.Ctx.t * 'g1 PR6437.Var.t -> 'g2 PR6437.Var.t =
+  <fun>
+# 

diff --git a/testsuite/tests/typing-poly/Makefile b/testsuite/tests/typing-poly/Makefile
index 7fc00661cbe83513fbab37e2fe27d89365c35054..0b15e777de9b37e51d0594072c80e3eef907fd3e 100644 (file)
--- a/testsuite/tests/typing-poly/Makefile
+++ b/testsuite/tests/typing-poly/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml
index 1ddc6d6cc283978030c441c499fa98df0c71d139..4b3d9e5db7f9f936f0b60d652f6c07d9a3d3d58f 100644 (file)
--- a/testsuite/tests/typing-poly/poly.ml
+++ b/testsuite/tests/typing-poly/poly.ml
@@ -10,6 +10,12 @@ type 'a t = { t : 'a };;
 type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b };;
 let f l = { fold = List.fold_left l };;
 (f [1;2;3]).fold ~f:(+) ~init:0;;
+[%%expect {|
+type 'a t = { t : 'a; }
+type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
+val f : 'a list -> 'a fold = <fun>
+- : int = 6
+|}];;
 
 class ['b] ilist l = object
   val l = l
@@ -18,11 +24,29 @@ class ['b] ilist l = object
     List.fold_left l
 end
 ;;
+[%%expect {|
+class ['b] ilist :
+  'b list ->
+  object ('c)
+    val l : 'b list
+    method add : 'b -> 'c
+    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
+  end
+|}];;
+
 class virtual ['a] vlist = object (_ : 'self)
   method virtual add : 'a -> 'self
   method virtual fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b
 end
 ;;
+[%%expect {|
+class virtual ['a] vlist :
+  object ('c)
+    method virtual add : 'a -> 'c
+    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class ilist2 l = object
   inherit [int] vlist
   val l = l
@@ -30,6 +54,16 @@ class ilist2 l = object
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ilist2 :
+  int list ->
+  object ('a)
+    val l : int list
+    method add : int -> 'a
+    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 let ilist2 l = object
   inherit [_] vlist
   val l = l
@@ -37,6 +71,10 @@ let ilist2 l = object
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+val ilist2 : 'a list -> 'a vlist = <fun>
+|}];;
+
 class ['a] ilist3 l = object
   inherit ['a] vlist
   val l = l
@@ -44,6 +82,16 @@ class ['a] ilist3 l = object
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ['a] ilist3 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class ['a] ilist4 (l : 'a list) = object
   val l = l
   method virtual add : _
@@ -52,6 +100,16 @@ class ['a] ilist4 (l : 'a list) = object
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ['a] ilist4 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class ['a] ilist5 (l : 'a list) = object (self)
   val l = l
   method add x = {< l = x :: l >}
@@ -61,6 +119,17 @@ class ['a] ilist5 (l : 'a list) = object (self)
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ['a] ilist5 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class ['a] ilist6 l = object (self)
   inherit ['a] vlist
   val l = l
@@ -70,15 +139,36 @@ class ['a] ilist6 l = object (self)
   method fold = List.fold_left l
 end
 ;;
+[%%expect {|
+class ['a] ilist6 :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
+  end
+|}];;
+
 class virtual ['a] olist = object
   method virtual fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c
 end
 ;;
+[%%expect {|
+class virtual ['a] olist :
+  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
+|}];;
+
 class ['a] onil = object
   inherit ['a] olist
   method fold ~f ~init = init
 end
 ;;
+[%%expect {|
+class ['a] onil :
+  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
+|}];;
+
 class ['a] ocons ~hd ~tl = object (_ : 'b)
   inherit ['a] olist
   val hd : 'a = hd
@@ -86,6 +176,17 @@ class ['a] ocons ~hd ~tl = object (_ : 'b)
   method fold ~f ~init = f hd (tl#fold ~f ~init)
 end
 ;;
+[%%expect {|
+class ['a] ocons :
+  hd:'a ->
+  tl:'a olist ->
+  object
+    val hd : 'a
+    val tl : 'a olist
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  end
+|}];;
+
 class ['a] ostream ~hd ~tl = object (_ : 'b)
   inherit ['a] olist
   val hd : 'a = hd
@@ -94,6 +195,18 @@ class ['a] ostream ~hd ~tl = object (_ : 'b)
   method empty = false
 end
 ;;
+[%%expect {|
+class ['a] ostream :
+  hd:'a ->
+  tl:'a ostream ->
+  object
+    val hd : 'a
+    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
+    method empty : bool
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+  end
+|}];;
+
 class ['a] ostream1 ~hd ~tl = object (self : 'b)
   inherit ['a] olist
   val hd = hd
@@ -103,33 +216,78 @@ class ['a] ostream1 ~hd ~tl = object (self : 'b)
   method fold ~f ~init =
     self#tl#fold ~f ~init:(f self#hd init)
 end
-;;
+[%%expect {|
+class ['a] ostream1 :
+  hd:'a ->
+  tl:'b ->
+  object ('b)
+    val hd : 'a
+    val tl : 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method hd : 'a
+    method tl : 'b
+  end
+|}, Principal{|
+Line _, characters 4-16:
+Warning 18: this use of a polymorphic method is not principal.
+class ['a] ostream1 :
+  hd:'a ->
+  tl:'b ->
+  object ('b)
+    val hd : 'a
+    val tl : 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method hd : 'a
+    method tl : 'b
+  end
+|}];;
 
 class vari = object
   method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
   method m = function `A -> 1 | `B|`C  -> 0
 end
 ;;
+[%%expect {|
+class vari : object method m : [< `A | `B | `C ] -> int end
+|}];;
+
 class vari = object
   method m : 'a. ([< `A|`B|`C] as 'a) -> int = function `A -> 1 | `B|`C -> 0
 end
 ;;
+[%%expect {|
+class vari : object method m : [< `A | `B | `C ] -> int end
+|}];;
+
 module V =
   struct
     type v = [`A | `B | `C]
     let m : [< v] -> int = function `A -> 1 | #v -> 0
   end
 ;;
+[%%expect {|
+module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
+|}];;
+
 class varj = object
   method virtual m : 'a. ([< V.v] as 'a) -> int
   method m = V.m
 end
 ;;
+[%%expect {|
+class varj : object method m : [< V.v ] -> int end
+|}];;
+
 
 module type T = sig
   class vari : object method m : 'a. ([< `A | `B | `C] as 'a) -> int end
 end
 ;;
+[%%expect {|
+module type T =
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+|}];;
+
 module M0 = struct
   class vari = object
     method virtual m : 'a. ([< `A|`B|`C] as 'a) -> int
@@ -137,10 +295,27 @@ module M0 = struct
   end
 end
 ;;
+[%%expect {|
+module M0 :
+  sig class vari : object method m : [< `A | `B | `C ] -> int end end
+|}];;
+
 module M : T = M0
 ;;
+[%%expect {|
+module M : T
+|}];;
+
 let v = new M.vari;;
+[%%expect {|
+val v : M.vari = <obj>
+|}];;
+
 v#m `A;;
+[%%expect {|
+- : int = 1
+|}];;
+
 
 class point ~x ~y = object
   val x : int = x
@@ -149,12 +324,33 @@ class point ~x ~y = object
   method y = y
 end
 ;;
+[%%expect {|
+class point :
+  x:int ->
+  y:int -> object val x : int val y : int method x : int method y : int end
+|}];;
+
 class color_point ~x ~y ~color = object
   inherit point ~x ~y
   val color : string = color
   method color = color
 end
 ;;
+[%%expect {|
+class color_point :
+  x:int ->
+  y:int ->
+  color:string ->
+  object
+    val color : string
+    val x : int
+    val y : int
+    method color : string
+    method x : int
+    method y : int
+  end
+|}];;
+
 class circle (p : #point) ~r = object
   val p = (p :> point)
   val r = r
@@ -165,6 +361,13 @@ class circle (p : #point) ~r = object
     if d < 0. then 0. else d
 end
 ;;
+[%%expect {|
+class circle :
+  #point ->
+  r:int ->
+  object val p : point val r : int method distance : #point -> float end
+|}];;
+
 let p0 = new point ~x:3 ~y:5
 let p1 = new point ~x:10 ~y:13
 let cp = new color_point ~x:12 ~y:(-5) ~color:"green"
@@ -175,21 +378,43 @@ let f (x : < m : 'a. 'a -> 'a >) = (x : < m : 'b. 'b -> 'b >)
 ;;
 let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
 ;;
+[%%expect {|
+val p0 : point = <obj>
+val p1 : point = <obj>
+val cp : color_point = <obj>
+val c : circle = <obj>
+val d : float = 11.
+val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
+Line _, characters 41-42:
+Error: This expression has type < m : 'b. 'b -> 'b list >
+       but an expression was expected of type < m : 'b. 'b -> 'c >
+       The universal variable 'b would escape its scope
+|}];;
 
 class id = object
   method virtual id : 'a. 'a -> 'a
   method id x = x
 end
 ;;
+[%%expect {|
+class id : object method id : 'a -> 'a end
+|}];;
 
 class type id_spec = object
   method id : 'a -> 'a
 end
 ;;
+[%%expect {|
+class type id_spec = object method id : 'a -> 'a end
+|}];;
+
 class id_impl = object (_ : #id_spec)
   method id x = x
 end
 ;;
+[%%expect {|
+class id_impl : object method id : 'a -> 'a end
+|}];;
 
 class a = object
   method m = (new b : id_spec)#id true
@@ -198,23 +423,43 @@ and b = object (_ : #id_spec)
   method id x = x
 end
 ;;
+[%%expect {|
+class a : object method m : bool end
+and b : object method id : 'a -> 'a end
+|}];;
+
 
 class ['a] id1 = object
   method virtual id : 'b. 'b -> 'a
   method id x = x
 end
 ;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+|}];;
+
 class id2 (x : 'a) = object
   method virtual id : 'b. 'b -> 'a
   method id x = x
 end
 ;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
+|}];;
+
 class id3 x = object
   val x = x
   method virtual id : 'a. 'a -> 'a
   method id _ = x
 end
 ;;
+[%%expect {|
+Line _, characters 12-17:
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
+|}];;
+
 class id4 () = object
   val mutable r = None
   method virtual id : 'a. 'a -> 'a
@@ -224,11 +469,20 @@ class id4 () = object
     | Some y -> y
 end
 ;;
+[%%expect {|
+Line _, characters 12-79:
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
+|}];;
+
 class c = object
   method virtual m : 'a 'b. 'a -> 'b -> 'a
   method m x y = x
 end
 ;;
+[%%expect {|
+class c : object method m : 'a -> 'b -> 'a end
+|}];;
+
 
 let f1 (f : id) = f#id 1, f#id true
 ;;
@@ -238,12 +492,23 @@ let f3 f = f#id 1, f#id true
 ;;
 let f4 f = ignore(f : id); f#id 1, f#id true
 ;;
+[%%expect {|
+val f1 : id -> int * bool = <fun>
+val f2 : id -> int * bool = <fun>
+Line _, characters 24-28:
+Error: This expression has type bool but an expression was expected of type
+         int
+|}];;
 
 class c = object
   method virtual m : 'a. (#id as 'a) -> int * bool
   method m (f : #id) = f#id 1, f#id true
 end
 ;;
+[%%expect {|
+class c : object method m : #id -> int * bool end
+|}];;
+
 
 class id2 = object (_ : 'b)
   method virtual id : 'a. 'a -> 'a
@@ -255,11 +520,21 @@ let app = new c #m (new id2)
 ;;
 type 'a foo = 'a foo list
 ;;
+[%%expect {|
+class id2 : object method id : 'a -> 'a method mono : int -> int end
+val app : int * bool = (1, true)
+Line _, characters 0-25:
+Error: The type abbreviation foo is cyclic
+|}];;
 
 class ['a] bar (x : 'a) = object end
 ;;
 type 'a foo = 'a foo bar
 ;;
+[%%expect {|
+class ['a] bar : 'a -> object  end
+type 'a foo = 'a foo bar
+|}];;
 
 fun x -> (x : < m : 'a. 'a * 'b > as 'b)#m;;
 fun x -> (x : < m : 'a. 'b * 'a list> as 'b)#m;;
@@ -268,17 +543,63 @@ fun (x : < p : 'a. < m : 'a ; n : 'b ; .. > as 'a > as 'b) -> x#p;;
 fun (x : <m:'a. 'a * <p:'b. 'b * 'c * 'd> as 'c> as 'd) -> x#m;;
 (* printer is wrong on the next (no official syntax) *)
 fun (x : <m:'a.<p:'a;..> >) -> x#m;;
+[%%expect {|
+- : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = <fun>
+- : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = <fun>
+val f :
+  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
+  'a * (< n : 'c; .. > as 'c) = <fun>
+- : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
+    (< m : 'c; n : 'a; .. > as 'c)
+= <fun>
+- : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
+    ('f * < p : 'b. 'b * 'e * 'c > as 'e)
+= <fun>
+- : < m : 'a. < p : 'a; .. > as 'b > -> 'b = <fun>
+|}, Principal{|
+- : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = <fun>
+- : (< m : 'a. 'b * 'a list > as 'b) ->
+    (< m : 'a. 'c * 'a list > as 'c) * 'd list
+= <fun>
+val f :
+  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
+  (< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) =
+  <fun>
+- : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
+    (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
+= <fun>
+- : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
+    ('f *
+     < p : 'b.
+             'b * 'e *
+             (< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) >
+     as 'e)
+= <fun>
+- : < m : 'a. < p : 'a; .. > as 'b > -> 'b = <fun>
+|}];;
 
 type sum = T of < id: 'a. 'a -> 'a > ;;
 fun (T x) -> x#id;;
+[%%expect {|
+type sum = T of < id : 'a. 'a -> 'a >
+- : sum -> 'a -> 'a = <fun>
+|}];;
 
 type record = { r: < id: 'a. 'a -> 'a > } ;;
 fun x -> x.r#id;;
 fun {r=x} -> x#id;;
+[%%expect {|
+type record = { r : < id : 'a. 'a -> 'a >; }
+- : record -> 'a -> 'a = <fun>
+- : record -> 'a -> 'a = <fun>
+|}];;
 
 class myself = object (self)
   method self : 'a. 'a -> 'b = fun _ -> self
 end;;
+[%%expect {|
+class myself : object ('b) method self : 'a -> 'b end
+|}];;
 
 class number = object (self : 'self)
   val num = 0
@@ -291,6 +612,16 @@ class number = object (self : 'self)
       if num = 0 then zero () else prev {< num = num - 1 >}
 end
 ;;
+[%%expect {|
+class number :
+  object ('b)
+    val num : int
+    method num : int
+    method prev : 'b
+    method succ : 'b
+    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
+  end
+|}];;
 
 let id x = x
 ;;
@@ -325,20 +656,57 @@ let count (l : 'a #olist) = l#fold ~f:(fun _ acc -> acc+1) ~init:0
 let append (l : 'a #olist) (l' : 'b #olist) =
   l#fold ~init:l' ~f:(fun x acc -> acc#cons x)
 ;;
+[%%expect {|
+val id : 'a -> 'a = <fun>
+class c : object method id : 'a -> 'a end
+class c' : object method id : 'a -> 'a end
+class d :
+  object
+    val mutable count : int
+    method count : int
+    method id : 'a -> 'a
+    method old : 'a -> 'a
+  end
+class ['a] olist :
+  'a list ->
+  object ('c)
+    val l : 'a list
+    method cons : 'a -> 'c
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+  end
+val sum : int #olist -> int = <fun>
+val count : 'a #olist -> int = <fun>
+val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
+|}];;
 
 type 'a t = unit
 ;;
 class o = object method x : 'a. ([> `A] as 'a) t -> unit = fun _ -> () end
 ;;
+[%%expect {|
+type 'a t = unit
+class o : object method x : [> `A ] t -> unit end
+|}];;
 
 class c = object method m = new d () end and d ?(x=0) () = object end;;
 class d ?(x=0) () = object end and c = object method m = new d () end;;
+[%%expect {|
+class c : object method m : d end
+and d : ?x:int -> unit -> object  end
+class d : ?x:int -> unit -> object  end
+and c : object method m : d end
+|}];;
 
 class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
 class zero = object (_ : #numeral) method fold f x = x end
 class next (n : #numeral) =
   object (_ : #numeral) method fold f x = n#fold f (f x) end
 ;;
+[%%expect {|
+class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
+class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
+class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
+|}];;
 
 class type node_type =  object
   method as_variant : [> `Node of node_type]
@@ -350,17 +718,37 @@ end;;
 class node = object (self : #node_type)
   method as_variant = `Node (self :> node_type)
 end;;
+[%%expect {|
+class type node_type = object method as_variant : [> `Node of node_type ] end
+class node : node_type
+class node : object method as_variant : [> `Node of node_type ] end
+|}];;
 
 type bad = {bad : 'a. 'a option ref};;
 let bad = {bad = ref None};;
 type bad2 = {mutable bad2 : 'a. 'a option ref option};;
 let bad2 = {bad2 = None};;
 bad2.bad2 <- Some (ref None);;
+[%%expect {|
+type bad = { bad : 'a. 'a option ref; }
+Line _, characters 17-25:
+Error: This field value has type 'b option ref which is less general than
+         'a. 'a option ref
+|}];;
 
 (* Type variable scope *)
 
 let f (x: <m:'a.<p: 'a * 'b> as 'b>) (y : 'b) = ();;
 let f (x: <m:'a. 'a * (<p:int*'b> as 'b)>) (y : 'b) = ();;
+[%%expect {|
+val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = <fun>
+val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = <fun>
+|}, Principal{|
+val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = <fun>
+val f :
+  < m : 'a. 'a * (< p : int * 'b > as 'b) > ->
+  (< p : int * 'c > as 'c) -> unit = <fun>
+|}];;
 
 (* PR#1374 *)
 
@@ -377,60 +765,130 @@ end;;
 class c = object (self)
   method m :  'a. ([> 'a t] as 'a) -> 'a = fun x -> self#m x
 end;;
+[%%expect {|
+type 'a t = [ `A of 'a ]
+class c : object method m : ([> 'a t ] as 'a) -> unit end
+class c : object method m : ([> 'a t ] as 'a) -> unit end
+class c : object method m : ([> 'a t ] as 'a) -> 'a end
+|}];;
 
 (* use before instancing *)
 class c = object method m : 'a. 'a option -> ([> `A] as 'a) = fun x -> `A end;;
+[%%expect {|
+class c : object method m : ([> `A ] as 'a) option -> 'a end
+|}];;
 
 (* various old bugs *)
 class virtual ['a] visitor =
 object method virtual caseNil : 'a end
 and virtual int_list =
 object method virtual visit : 'a.('a visitor -> 'a) end;;
+[%%expect {|
+Line _, characters 30-51:
+Error: The universal type variable 'a cannot be generalized:
+       it escapes its scope.
+|}];;
 
 type ('a,'b) list_visitor = < caseNil : 'a; caseCons : 'b -> 'b list -> 'a >
 type 'b alist = < visit : 'a. ('a,'b) list_visitor -> 'a >
+[%%expect {|
+type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
+type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
+|}];;
 
 (* PR#1607 *)
 class type ct = object ('s)
   method fold : ('b -> 's -> 'b) -> 'b -> 'b
 end
 type t = {f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b};;
+[%%expect {|
+class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
+type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
+|}];;
 
 (* PR#1663 *)
 type t = u and u = t;;
+[%%expect {|
+Line _, characters 0-10:
+Error: The definition of t contains a cycle:
+       u
+|}];;
 
 (* PR#1731 *)
 class ['t] a = object constraint 't = [> `A of 't a] end
 type t = [ `A of t a ];;
+[%%expect {|
+class ['a] a : object constraint 'a = [> `A of 'a a ] end
+type t = [ `A of t a ]
+|}];;
 
 (* Wrong in 3.06 *)
 type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
+[%%expect {|
+Line _, characters 50-59:
+Error: Constraints are not satisfied in this type.
+       Type ('a, 'b) t should be an instance of ('c, 'c) t
+|}];;
 
 (* Full polymorphism if we do not expand *)
 type 'a t = 'a and u = int t;;
+[%%expect {|
+type 'a t = 'a
+and u = int t
+|}];;
 
 (* Loose polymorphism if we expand *)
 type 'a t constraint 'a = int;;
 type 'a u = 'a and 'a v = 'a u t;;
 type 'a u = 'a and 'a v = 'a u t constraint 'a = int;;
+[%%expect {|
+type 'a t constraint 'a = int
+Line _, characters 26-32:
+Error: Constraints are not satisfied in this type.
+       Type 'a u t should be an instance of int t
+|}];;
 
 (* Behaviour is unstable *)
 type g = int;;
 type 'a t = unit constraint 'a = g;;
 type 'a u = 'a and 'a v = 'a u t;;
 type 'a u = 'a and 'a v = 'a u t constraint 'a = int;;
+[%%expect {|
+type g = int
+type 'a t = unit constraint 'a = g
+Line _, characters 26-32:
+Error: Constraints are not satisfied in this type.
+       Type 'a u t should be an instance of g t
+|}];;
 
 (* Example of wrong expansion *)
 type 'a u = < m : 'a v > and 'a v = 'a list u;;
+[%%expect {|
+Line _, characters 0-24:
+Error: In the definition of v, type 'a list u should be 'a u
+|}];;
 
 (* PR#1744: Ctype.matches *)
 type 'a t = 'a
 type 'a u = A of 'a t;;
+[%%expect {|
+type 'a t = 'a
+type 'a u = A of 'a t
+|}];;
 
 (* Unification of cyclic terms *)
 type 'a t = < a : 'a >;;
 fun (x : 'a t as 'a) -> (x : 'b t);;
 type u = 'a t as 'a;;
+[%%expect {|
+type 'a t = < a : 'a >
+- : ('a t as 'a) -> 'a t = <fun>
+type u = 'a t as 'a
+|}, Principal{|
+type 'a t = < a : 'a >
+- : ('a t as 'a) -> ('b t as 'b) t = <fun>
+type u = 'a t as 'a
+|}];;
 
 
 (* Variant tests *)
@@ -445,10 +903,43 @@ function `A, A -> 1 | `B, A -> 2 | _, B -> 3;;
 function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
 function `B,1 -> 1 | _,1 -> 2;;
 function 1,`B -> 1 | 1,_ -> 2;;
+[%%expect {|
+type t = A | B
+- : [> `A ] * t -> int = <fun>
+- : [> `A ] * t -> int = <fun>
+- : [> `A ] option * t -> int = <fun>
+- : [> `A ] option * t -> int = <fun>
+- : t * [< `A | `B ] -> int = <fun>
+- : [< `A | `B ] * t -> int = <fun>
+Line _, characters 0-41:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(`AnyExtraTag, `AnyExtraTag)
+- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
+Line _, characters 0-29:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(_, 0)
+Line _, characters 21-24:
+Warning 11: this match case is unused.
+- : [< `B ] * int -> int = <fun>
+Line _, characters 0-29:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(0, _)
+Line _, characters 21-24:
+Warning 11: this match case is unused.
+- : int * [< `B ] -> int = <fun>
+|}];;
 
 (* pass typetexp, but fails during Typedecl.check_recursion *)
 type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
 and  ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];;
+[%%expect {|
+Line _, characters 0-71:
+Error: The definition of a contains a cycle:
+       [> `B of ('a, 'b) b as 'b ] as 'a
+|}];;
 
 (* PR#1917: expanding may change original in Ctype.unify2 *)
 (* Note: since 3.11, the abbreviations are not used when printing
@@ -460,12 +951,45 @@ end and ['a, 'b] b = object
   method a: ('a, 'b) #a as 'a
   method as_b: ('a, 'b) b
 end;;
+[%%expect {|
+class type ['a, 'b] a =
+  object
+    constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
+    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
+    method as_a : 'c
+    method b : 'b
+  end
+and ['a, 'b] b =
+  object
+    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
+    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+|}];;
 
 class type ['b] ca = object ('s) inherit ['s, 'b] a end;;
 class type ['a] cb = object ('s) inherit ['a, 's] b end;;
+[%%expect {|
+class type ['a] ca =
+  object ('b)
+    constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
+    method as_a : ('b, 'a) a
+    method b : 'a
+  end
+class type ['a] cb =
+  object ('b)
+    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
+    method a : 'a
+    method as_b : ('a, 'b) b
+  end
+|}];;
 
 type bt = 'b ca cb as 'b
 ;;
+[%%expect {|
+type bt = 'a ca cb as 'a
+|}];;
 
 (* final classes, etc... *)
 class c = object method m = 1 end;;
@@ -484,6 +1008,19 @@ let o = object (_ : 's)
   method private m =
     object (self: 's) method x = 3 method private m = self end
 end;;
+[%%expect {|
+class c : object method m : int end
+val f : unit -> c = <fun>
+val f : unit -> c = <fun>
+Line _, characters 11-60:
+Warning 15: the following private methods were made public implicitly:
+ n.
+val f : unit -> < m : int; n : int > = <fun>
+Line _, characters 11-56:
+Error: This object is expected to have type c but actually has type
+         < m : int; n : 'a >
+       The first object type has no method n
+|}];;
 
 
 (* Unsound! *)
@@ -494,6 +1031,13 @@ type foo' =   <m: 'a. 'a * 'a foo>
 type 'a bar = <m: 'b. 'a * <m: 'c. 'c * 'a bar> >
 type bar' =   <m: 'a. 'a * 'a bar >
 let f (x : foo') = (x : bar');;
+[%%expect {|
+Line _, characters 3-4:
+Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
+       but an expression was expected of type
+         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
+       Types for method m are incompatible
+|}];;
 
 fun (x : <m : 'a. 'a * ('a * <m : 'a. 'a * 'foo> as 'foo)>) ->
   (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('c * 'bar)>)> as 'bar);;
@@ -504,6 +1048,14 @@ fun (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) ->
 let f x =
     (x : <m : 'a. 'a -> ('a * <m:'c. 'c -> 'bar> as 'bar)>
        :> <m : 'a. 'a -> ('a * 'foo)> as 'foo);;
+[%%expect {|
+Line _, characters 3-4:
+Error: This expression has type
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
+       but an expression was expected of type
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
+       Types for method m are incompatible
+|}];;
 
 module M
 : sig val f : (<m : 'b. 'b * ('b * <m:'c. 'c * 'bar> as 'bar)>) -> unit end
@@ -511,6 +1063,20 @@ module M
 module M
 : sig type t = <m : 'b. 'b * ('b * <m:'c. 'c * 'bar> as 'bar)> end
 = struct type t = <m : 'a. 'a * ('a * 'foo)> as 'foo end;;
+[%%expect {|
+Line _, characters 2-64:
+Error: Signature mismatch:
+       Modules do not match:
+         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
+       is not included in
+         sig
+           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
+         end
+       Values do not match:
+         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
+       is not included in
+         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
+|}];;
 
 module M : sig type 'a t type u = <m: 'a. 'a t> end
 = struct type 'a t = int type u = <m: int> end;;
@@ -519,11 +1085,21 @@ module M : sig type 'a t val f : <m: 'a. 'a t> -> int end
 (* The following should be accepted too! *)
 module M : sig type 'a t val f : <m: 'a. 'a t> -> int end
 = struct type 'a t = int let f x = x#m end;;
+[%%expect {|
+module M : sig type 'a t type u = < m : 'a. 'a t > end
+module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
+module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
+|}];;
 
 let f x y =
   ignore (x :> <m:'a.'a -> 'c * < > > as 'c);
   ignore (y :> <m:'b.'b -> 'd * < > > as 'd);
   x = y;;
+[%%expect {|
+val f :
+  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
+  'b -> bool = <fun>
+|}];;
 
 
 (* Subtyping *)
@@ -540,6 +1116,15 @@ type p = <x:p>;;
 type q = private <x:p; ..>;;
 fun x -> (x : q :> p);;
 fun x -> (x : p :> q);;
+[%%expect {|
+type t = [ `A | `B ]
+type v = private [> t ]
+- : t -> v = <fun>
+type u = private [< t ]
+- : u -> v = <fun>
+Line _, characters 9-21:
+Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ]
+|}];;
 
 let f1 x =
   (x : <m:'a. (<p:int;..> as 'a) -> int>
@@ -555,6 +1140,13 @@ let f5 x =
   (x : <m:'a. [< `A of <p:int> ] as 'a> :> <m:'a. [< `A of < > ] as 'a>);;
 let f6 x =
   (x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
+[%%expect {|
+Line _, characters 2-88:
+Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
+         < m : 'b. (< p : int; q : int; .. > as 'b) -> int >
+       Type < p : int; q : int; .. > as 'c is not a subtype of
+         < p : int; .. > as 'd
+|}];;
 
 (* Keep sharing the epsilons *)
 let f x = if true then (x : < m : 'a. 'a -> 'a >) else x;;
@@ -563,6 +1155,27 @@ let f (x, y) = if true then (x : < m : 'a. 'a -> 'a >) else x;;
 fun x -> (f (x,x))#m;; (* Warning 18 *)
 let f x = if true then [| (x : < m : 'a. 'a -> 'a >) |] else [|x|];;
 fun x -> (f x).(0)#m;; (* Warning 18 *)
+[%%expect {|
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+|}, Principal{|
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
+Line _, characters 9-16:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
+Line _, characters 9-20:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
+Line _, characters 9-20:
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+|}];;
 
 (* Not really principal? *)
 class c = object method id : 'a. 'a -> 'a = fun x -> x end;;
@@ -575,11 +1188,35 @@ let g x =
 let h x =
   let none = let y = None in ignore [y;(None:u)]; y in
   let x = List.hd [Some x; none] in (just x)#id;;
+[%%expect {|
+class c : object method id : 'a -> 'a end
+type u = c option
+val just : 'a option -> 'a = <fun>
+val f : c -> 'a -> 'a = <fun>
+val g : c -> 'a -> 'a = <fun>
+val h : < id : 'a; .. > -> 'a = <fun>
+|}, Principal{|
+class c : object method id : 'a -> 'a end
+type u = c option
+val just : 'a option -> 'a = <fun>
+Line _, characters 42-62:
+Warning 18: this use of a polymorphic method is not principal.
+val f : c -> 'a -> 'a = <fun>
+Line _, characters 36-47:
+Warning 18: this use of a polymorphic method is not principal.
+val g : c -> 'a -> 'a = <fun>
+val h : < id : 'a; .. > -> 'a = <fun>
+|}];;
 
 (* Only solved for parameterless abbreviations *)
 type 'a u = c option;;
 let just = function None -> failwith "just" | Some x -> x;;
 let f x = let l = [Some x; (None : _ u)] in (just(List.hd l))#id;;
+[%%expect {|
+type 'a u = c option
+val just : 'a option -> 'a = <fun>
+val f : c -> 'a -> 'a = <fun>
+|}];;
 
 (* polymorphic recursion *)
 
@@ -601,20 +1238,45 @@ and q () = r;;
 let f : 'a. _ -> _ = fun x -> x;;
 let zero : 'a. [> `Int of int | `B of 'a] as 'a  = `Int 0;; (* ok *)
 let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
+[%%expect {|
+val f : 'a -> int = <fun>
+val g : 'a -> int = <fun>
+type 'a t = Leaf of 'a | Node of ('a * 'a) t
+val depth : 'a t -> int = <fun>
+Line _, characters 2-42:
+Error: This definition has type 'a t -> int which is less general than
+         'a0. 'a0 t -> int
+|}];;
 
 (* compare with records (should be the same) *)
 type t = {f: 'a. [> `Int of int | `B of 'a] as 'a}
 let zero = {f = `Int 0} ;;
 type t = {f: 'a. [< `Int of int] as 'a}
 let zero = {f = `Int 0} ;; (* fails *)
+[%%expect {|
+type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
+val zero : t = {f = `Int 0}
+type t = { f : 'a. [< `Int of int ] as 'a; }
+Line _, characters 16-22:
+Error: This expression has type [> `Int of int ]
+       but an expression was expected of type [< `Int of int ]
+       Types for tag `Int are incompatible
+|}];;
 
 (* Yet another example *)
 let rec id : 'a. 'a -> 'a = fun x -> x
 and neg i b = (id (-i), id (not b));;
+[%%expect {|
+val id : 'a -> 'a = <fun>
+val neg : int -> bool -> int * bool = <fun>
+|}];;
 
 (* De Xavier *)
 
 type t = A of int | B of (int*t) list | C of (string*t) list
+[%%expect {|
+type t = A of int | B of (int * t) list | C of (string * t) list
+|}];;
 
 let rec transf f = function
   | A x -> f x
@@ -624,16 +1286,31 @@ and transf_alist : 'a. _ -> ('a*t) list -> ('a*t) list = fun f -> function
   | [] -> []
   | (k,v)::tl -> (k, transf f v) :: transf_alist f tl
 ;;
+[%%expect {|
+val transf : (int -> t) -> t -> t = <fun>
+val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun>
+|}];;
 
 (* PR#4862 *)
 
 type t = {f: 'a. ('a list -> int) Lazy.t}
 let l : t = { f = lazy (raise Not_found)};;
+[%%expect {|
+type t = { f : 'a. ('a list -> int) Lazy.t; }
+val l : t = {f = <lazy>}
+|}];;
 
 (* variant *)
 type t = {f: 'a. 'a -> unit};;
 let f ?x y = () in {f};;
 let f ?x y = y in {f};; (* fail *)
+[%%expect {|
+type t = { f : 'a. 'a -> unit; }
+- : t = {f = <fun>}
+Line _, characters 19-20:
+Error: This field value has type unit -> unit which is less general than
+         'a. 'a -> unit
+|}];;
 
 (* Polux Moon caml-list 2011-07-26 *)
 module Polux = struct
@@ -642,6 +1319,15 @@ module Polux = struct
   class alias = object method alias : 'a . 'a t -> 'a = ident end
   let f (x : <m : 'a. 'a t>) = (x : <m : 'a. 'a>)
 end;;
+[%%expect {|
+module Polux :
+  sig
+    type 'par t = 'par
+    val ident : 'a -> 'a
+    class alias : object method alias : 'a t -> 'a end
+    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
+  end
+|}];;
 
 (* PR#5560 *)
 
@@ -650,10 +1336,17 @@ type t = { foo : int }
 let {foo} = (raise Exit : t);;
 type s = A of int
 let (A x) = (raise Exit : s);;
+[%%expect {|
+Exception: Pervasives.Exit.
+|}];;
 
 (* PR#5224 *)
 
 type 'x t = < f : 'y. 'y t >;;
+[%%expect {|
+Line _, characters 0-28:
+Error: In the definition of t, type 'y t should be 'x t
+|}];;
 
 (* PR#6056, PR#6057 *)
 let using_match b =
@@ -664,26 +1357,93 @@ let using_match b =
   in
   f 0,f
 ;;
+[%%expect {|
+val using_match : bool -> int * ('a -> 'a) = <fun>
+|}];;
 
 match (fun x -> x), fun x -> x with x, y -> x, y;;
 match fun x -> x with x -> x, x;;
+[%%expect {|
+- : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
+- : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
+|}];;
 
 (* PR#6747 *)
 (* ok *)
 let n = object
   method m : 'x 'o. ([< `Foo of 'x] as 'o) -> 'x = fun x -> assert false
 end;;
+[%%expect {|
+val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = <obj>
+|}];;
 (* ok, but not with -principal *)
 let n =
   object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+val n : < m : 'x. [< `Foo of 'x ] -> 'x > = <obj>
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
 (* fail *)
 let (n : < m : 'a. [< `Foo of int] -> 'a >) =
   object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+Line _, characters 2-72:
+Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
+       but an expression was expected of type
+         < m : 'a. [< `Foo of int ] -> 'a >
+       The universal variable 'x would escape its scope
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
 (* fail *)
 let (n : 'b -> < m : 'a . ([< `Foo of int] as 'b) -> 'a >) = fun x ->
   object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
+[%%expect {|
+Line _, characters 2-72:
+Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
+       but an expression was expected of type
+         < m : 'a. [< `Foo of int ] -> 'a >
+       The universal variable 'x would escape its scope
+|}, Principal{|
+Line _, characters 47-68:
+Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
+       which is less general than 'x. 'a -> 'x
+|}];;
 
 (* PR#6171 *)
 let f b (x: 'x) =
   let module M = struct type t = A end in
   if b then x else M.A;;
+[%%expect {|
+Line _, characters 19-22:
+Error: This expression has type M.t but an expression was expected of type 'x
+       The type constructor M.t would escape its scope
+|}];;
+
+(* PR#7285 *)
+type (+'a,-'b) foo = private int;;
+let f (x : int) : ('a,'a) foo = Obj.magic x;;
+let x = f 3;;
+[%%expect{|
+type (+'a, -'b) foo = private int
+val f : int -> ('a, 'a) foo = <fun>
+val x : ('_a, '_a) foo = 3
+|}]
+
+(* PR#7395 *)
+type u
+type 'a t = u;;
+let c (f : u -> u) =
+ object
+   method apply: 'a. 'a t -> 'a t = fun x -> f x
+ end;;
+[%%expect{|
+type u
+type 'a t = u
+val c : (u -> u) -> < apply : 'a. 'a t -> 'a t > = <fun>
+|}]

diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference
deleted file mode 100644 (file)
index d852593..0000000
--- a/testsuite/tests/typing-poly/poly.ml.principal.reference
+++ /dev/null
@@ -1,675 +0,0 @@
-
-# * * *       #   type 'a t = { t : 'a; }
-# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
-# val f : 'a list -> 'a fold = <fun>
-# - : int = 6
-#               class ['b] ilist :
-  'b list ->
-  object ('c)
-    val l : 'b list
-    method add : 'b -> 'c
-    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
-  end
-#         class virtual ['a] vlist :
-  object ('c)
-    method virtual add : 'a -> 'c
-    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#             class ilist2 :
-  int list ->
-  object ('a)
-    val l : int list
-    method add : int -> 'a
-    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
-  end
-#             val ilist2 : 'a list -> 'a vlist = <fun>
-#             class ['a] ilist3 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#               class ['a] ilist4 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#                 class ['a] ilist5 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#                 class ['a] ilist6 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#       class virtual ['a] olist :
-  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
-#         class ['a] onil :
-  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
-#             class ['a] ocons :
-  hd:'a ->
-  tl:'a olist ->
-  object
-    val hd : 'a
-    val tl : 'a olist
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-  end
-#               class ['a] ostream :
-  hd:'a ->
-  tl:'a ostream ->
-  object
-    val hd : 'a
-    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
-    method empty : bool
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-  end
-#                   Characters 166-178:
-      self#tl#fold ~f ~init:(f self#hd init)
-      ^^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-class ['a] ostream1 :
-  hd:'a ->
-  tl:'b ->
-  object ('b)
-    val hd : 'a
-    val tl : 'b
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-    method hd : 'a
-    method tl : 'b
-  end
-#           class vari : object method m : [< `A | `B | `C ] -> int end
-#       class vari : object method m : [< `A | `B | `C ] -> int end
-#           module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
-#         class varj : object method m : [< V.v ] -> int end
-#         module type T =
-  sig class vari : object method m : [< `A | `B | `C ] -> int end end
-#             module M0 :
-  sig class vari : object method m : [< `A | `B | `C ] -> int end end
-#   module M : T
-# val v : M.vari = <obj>
-# - : int = 1
-#               class point :
-  x:int ->
-  y:int -> object val x : int val y : int method x : int method y : int end
-#           class color_point :
-  x:int ->
-  y:int ->
-  color:string ->
-  object
-    val color : string
-    val x : int
-    val y : int
-    method color : string
-    method x : int
-    method y : int
-  end
-#                   class circle :
-  #point ->
-  r:int ->
-  object val p : point val r : int method distance : #point -> float end
-#           val p0 : point = <obj>
-val p1 : point = <obj>
-val cp : color_point = <obj>
-val c : circle = <obj>
-val d : float = 11.
-#   val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
-#   Characters 41-42:
-  let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
-                                           ^
-Error: This expression has type < m : 'b. 'b -> 'b list >
-       but an expression was expected of type < m : 'b. 'b -> 'c >
-       The universal variable 'b would escape its scope
-#           class id : object method id : 'a -> 'a end
-#         class type id_spec = object method id : 'a -> 'a end
-#       class id_impl : object method id : 'a -> 'a end
-#               class a : object method m : bool end
-and b : object method id : 'a -> 'a end
-#           Characters 72-77:
-    method id x = x
-              ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-#         Characters 75-80:
-    method id x = x
-              ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-#           Characters 80-85:
-    method id _ = x
-              ^^^^^
-Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
-#                 Characters 92-159:
-  ............x =
-      match r with
-        None -> r <- Some x; x
-      | Some y -> y
-Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
-#         class c : object method m : 'a -> 'b -> 'a end
-#     val f1 : id -> int * bool = <fun>
-#   val f2 : id -> int * bool = <fun>
-#   Characters 24-28:
-  let f3 f = f#id 1, f#id true
-                          ^^^^
-Error: This expression has type bool but an expression was expected of type
-         int
-#   Characters 27-31:
-  let f4 f = ignore(f : id); f#id 1, f#id true
-                             ^^^^
-Warning 18: this use of a polymorphic method is not principal.
-Characters 35-39:
-  let f4 f = ignore(f : id); f#id 1, f#id true
-                                     ^^^^
-Warning 18: this use of a polymorphic method is not principal.
-val f4 : id -> int * bool = <fun>
-#           class c : object method m : #id -> int * bool end
-#             class id2 : object method id : 'a -> 'a method mono : int -> int end
-#   val app : int * bool = (1, true)
-#   Characters 0-25:
-  type 'a foo = 'a foo list
-  ^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The type abbreviation foo is cyclic
-#     class ['a] bar : 'a -> object  end
-#   type 'a foo = 'a foo bar
-#   - : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = <fun>
-# - : (< m : 'a. 'b * 'a list > as 'b) ->
-    (< m : 'a. 'c * 'a list > as 'c) * 'd list
-= <fun>
-# val f :
-  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
-  (< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) =
-  <fun>
-# - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
-    (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
-= <fun>
-# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
-    ('f *
-     < p : 'b.
-             'b * 'e *
-             (< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) >
-     as 'e)
-= <fun>
-#   - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = <fun>
-#   type sum = T of < id : 'a. 'a -> 'a >
-# - : sum -> 'a -> 'a = <fun>
-#   type record = { r : < id : 'a. 'a -> 'a >; }
-# - : record -> 'a -> 'a = <fun>
-# - : record -> 'a -> 'a = <fun>
-#       class myself : object ('b) method self : 'a -> 'b end
-#                       class number :
-  object ('b)
-    val num : int
-    method num : int
-    method prev : 'b
-    method succ : 'b
-    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
-  end
-#     val id : 'a -> 'a = <fun>
-#       class c : object method id : 'a -> 'a end
-#         class c' : object method id : 'a -> 'a end
-#               class d :
-  object
-    val mutable count : int
-    method count : int
-    method id : 'a -> 'a
-    method old : 'a -> 'a
-  end
-#             class ['a] olist :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method cons : 'a -> 'c
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
-  end
-#   val sum : int #olist -> int = <fun>
-#   val count : 'a #olist -> int = <fun>
-#     val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
-#     type 'a t = unit
-#   class o : object method x : [> `A ] t -> unit end
-#   class c : object method m : d end
-and d : ?x:int -> unit -> object  end
-# class d : ?x:int -> unit -> object  end
-and c : object method m : d end
-#           class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
-class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
-class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
-#       class type node_type = object method as_variant : [> `Node of node_type ] end
-#       class node : node_type
-#     class node : object method as_variant : [> `Node of node_type ] end
-#   type bad = { bad : 'a. 'a option ref; }
-# Characters 17-25:
-  let bad = {bad = ref None};;
-                   ^^^^^^^^
-Error: This field value has type 'b option ref which is less general than
-         'a. 'a option ref
-# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
-# val bad2 : bad2 = {bad2 = None}
-# Characters 13-28:
-  bad2.bad2 <- Some (ref None);;
-               ^^^^^^^^^^^^^^^
-Error: This field value has type 'b option ref option
-       which is less general than 'a. 'a option ref option
-#       val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = <fun>
-# val f :
-  < m : 'a. 'a * (< p : int * 'b > as 'b) > ->
-  (< p : int * 'c > as 'c) -> unit = <fun>
-#       type 'a t = [ `A of 'a ]
-#       class c : object method m : ([> 'a t ] as 'a) -> unit end
-#         class c : object method m : ([> 'a t ] as 'a) -> unit end
-#     class c : object method m : ([> 'a t ] as 'a) -> 'a end
-#     class c : object method m : ([> `A ] as 'a) option -> 'a end
-#           Characters 145-166:
-  object method virtual visit : 'a.('a visitor -> 'a) end;;
-                                ^^^^^^^^^^^^^^^^^^^^^
-Error: The universal type variable 'a cannot be generalized:
-       it escapes its scope.
-#                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
-class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
-type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
-#     Characters 15-25:
-  type t = u and u = t;;
-  ^^^^^^^^^^
-Error: The type abbreviation t is cyclic
-#       class ['a] a : object constraint 'a = [> `A of 'a a ] end
-type t = [ `A of t a ]
-#     Characters 71-80:
-  type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
-                                                    ^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type ('a, 'b) t should be an instance of ('c, 'c) t
-#     type 'a t = 'a
-and u = int t
-#     type 'a t constraint 'a = int
-# Characters 26-32:
-  type 'a u = 'a and 'a v = 'a u t;;
-                            ^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type 'a u t should be an instance of int t
-# type 'a u = 'a constraint 'a = int
-and 'a v = 'a u t constraint 'a = int
-#     type g = int
-# type 'a t = unit constraint 'a = g
-# Characters 26-32:
-  type 'a u = 'a and 'a v = 'a u t;;
-                            ^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type 'a u t should be an instance of g t
-# type 'a u = 'a constraint 'a = g
-and 'a v = 'a u t constraint 'a = g
-#     Characters 34-58:
-  type 'a u = < m : 'a v > and 'a v = 'a list u;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of v, type 'a list u should be 'a u
-#       type 'a t = 'a
-type 'a u = A of 'a t
-#     type 'a t = < a : 'a >
-# - : ('a t as 'a) -> ('b t as 'b) t = <fun>
-# type u = 'a t as 'a
-#       type t = A | B
-# - : [> `A ] * t -> int = <fun>
-# - : [> `A ] * t -> int = <fun>
-# - : [> `A ] option * t -> int = <fun>
-#   - : [> `A ] option * t -> int = <fun>
-# - : t * [< `A | `B ] -> int = <fun>
-# - : [< `A | `B ] * t -> int = <fun>
-# Characters 0-41:
-  function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(`AnyExtraTag, `AnyExtraTag)
-- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
-# Characters 0-29:
-  function `B,1 -> 1 | _,1 -> 2;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(_, 0)
-Characters 21-24:
-  function `B,1 -> 1 | _,1 -> 2;;
-                       ^^^
-Warning 11: this match case is unused.
-- : [< `B ] * int -> int = <fun>
-# Characters 0-29:
-  function 1,`B -> 1 | 1,_ -> 2;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(0, _)
-Characters 21-24:
-  function 1,`B -> 1 | 1,_ -> 2;;
-                       ^^^
-Warning 11: this match case is unused.
-- : int * [< `B ] -> int = <fun>
-#       Characters 64-135:
-  type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type
-       ([> `B of 'a ], 'a) b as 'a
-       should be an instance of
-       (('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b
-#     *               class type ['a, 'b] a =
-  object
-    constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
-    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
-    method as_a : 'c
-    method b : 'b
-  end
-and ['a, 'b] b =
-  object
-    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
-    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
-    method a : 'a
-    method as_b : ('a, 'b) b
-  end
-#   class type ['a] ca =
-  object ('b)
-    constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
-    method as_a : ('b, 'a) a
-    method b : 'a
-  end
-# class type ['a] cb =
-  object ('b)
-    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
-    method a : 'a
-    method as_b : ('a, 'b) b
-  end
-#     type bt = 'a ca cb as 'a
-#     class c : object method m : int end
-# val f : unit -> c = <fun>
-# val f : unit -> c = <fun>
-# Characters 11-60:
-  let f () = object method private n = 1 method m = {<>}#n end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 15: the following private methods were made public implicitly:
- n.
-val f : unit -> < m : int; n : int > = <fun>
-# Characters 11-56:
-  let f () = object (self:c) method n = 1 method m = 2 end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type c but actually has type
-         < m : int; n : 'a >
-       The first object type has no method n
-# Characters 11-69:
-  let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type < n : int > but actually has type
-         < m : 'a >
-       The second object type has no method n
-#         Characters 66-124:
-      object (self: 's) method x = 3 method private m = self end
-      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type < x : int; .. >
-       but actually has type < x : int >
-       Self type cannot be unified with a closed object type
-#         val o : < x : int > = <obj>
-#         Characters 76-77:
-    (x : <m : 'a. 'a * (<m:'b. 'a * <m:'c. 'c * 'bar> > as 'bar) >);;
-     ^
-Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
-       but an expression was expected of type
-         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
-       Types for method m are incompatible
-#         Characters 176-177:
-  let f (x : foo') = (x : bar');;
-                      ^
-Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
-       but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
-       Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > 
-       Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         < m : 'c. 'c * 'a bar > 
-       Types for method m are incompatible
-#     Characters 67-68:
-    (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('c * 'bar)>)> as 'bar);;
-     ^
-Error: This expression has type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
-       Types for method m are incompatible
-#   Characters 66-67:
-    (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('b * 'bar)>)> as 'bar);;
-     ^
-Error: This expression has type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
-       Types for method m are incompatible
-#   Characters 51-52:
-    (x : <m : 'b. 'b * ('b * <m:'c. 'c * 'bar> as 'bar)>);;
-     ^
-Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
-       Types for method m are incompatible
-#     Characters 14-115:
-  ....(x : <m : 'a. 'a -> ('a * <m:'c. 'c -> 'bar> as 'bar)>
-         :> <m : 'a. 'a -> ('a * 'foo)> as 'foo)..
-Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
-       is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f 
-       Type 'c. 'e is not a subtype of 'a. 'g 
-#       Characters 88-150:
-  = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
-       is not included in
-         sig
-           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
-         end
-       Values do not match:
-         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
-       is not included in
-         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
-#     Characters 78-132:
-  = struct type t = <m : 'a. 'a * ('a * 'foo)> as 'foo end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
-       is not included in
-         sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
-       Type declarations do not match:
-         type t = < m : 'a. 'a * ('a * 'b) > as 'b
-       is not included in
-         type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-#     module M : sig type 'a t type u = < m : 'a. 'a t > end
-#   module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
-#     module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
-#         val f :
-  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
-  'b -> bool = <fun>
-#         type t = [ `A | `B ]
-# type v = private [> t ]
-# - : t -> v = <fun>
-# type u = private [< t ]
-# - : u -> v = <fun>
-# Characters 9-21:
-  fun x -> (x : v :> u);;
-           ^^^^^^^^^^^^
-Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] 
-# type v = private [< t ]
-# Characters 9-21:
-  fun x -> (x : u :> v);;
-           ^^^^^^^^^^^^
-Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] 
-# type p = < x : p >
-# type q = private < x : p; .. >
-# - : q -> p = <fun>
-# Characters 9-21:
-  fun x -> (x : p :> q);;
-           ^^^^^^^^^^^^
-Error: Type p = < x : p > is not a subtype of q = < x : p; .. > 
-#       Characters 14-100:
-  ..(x : <m:'a. (<p:int;..> as 'a) -> int>
-      :> <m:'b. (<p:int;q:int;..> as 'b) -> int>)..
-Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
-         < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
-       Type < p : int; q : int; .. > as 'c is not a subtype of
-         < p : int; .. > as 'd 
-#     val f2 :
-  < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
-  < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun>
-#     Characters 13-107:
-  ..(x : <m:'a. (<p:<a:int;b:int>;..> as 'a) -> int>
-      :> <m:'b. (<p:<a:int>;..> as 'b) -> int>)..
-Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
-       is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
-       Type < a : int > is not a subtype of < a : int; b : int > 
-# Characters 11-55:
-  let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type < p : < a : int; b : int >; .. > is not a subtype of
-         < p : < a : int >; .. > 
-       The second object type has no method b
-#   val f5 :
-  < m : 'a. [< `A of < p : int > ] as 'a > ->
-  < m : 'b. [< `A of <  > ] as 'b > = <fun>
-#   Characters 13-83:
-    (x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
-         < m : 'b. [< `A of < p : int > ] as 'b > 
-       Type <  > is not a subtype of < p : int > 
-#     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
-# Characters 9-16:
-  fun x -> (f x)#m;; (* Warning 18 *)
-           ^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
-# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
-# Characters 9-20:
-  fun x -> (f (x,x))#m;; (* Warning 18 *)
-           ^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
-# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
-# Characters 9-20:
-  fun x -> (f x).(0)#m;; (* Warning 18 *)
-           ^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
-#     class c : object method id : 'a -> 'a end
-# type u = c option
-# val just : 'a option -> 'a = <fun>
-# Characters 42-62:
-  let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
-                                            ^^^^^^^^^^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-val f : c -> 'a -> 'a = <fun>
-#     Characters 101-112:
-    let x = List.hd [Some x; none] in (just x)#id;;
-                                      ^^^^^^^^^^^
-Warning 18: this use of a polymorphic method is not principal.
-val g : c -> 'a -> 'a = <fun>
-#     val h : < id : 'a; .. > -> 'a = <fun>
-#     type 'a u = c option
-# val just : 'a option -> 'a = <fun>
-# val f : c -> 'a -> 'a = <fun>
-#       val f : 'a -> int = <fun>
-val g : 'a -> int = <fun>
-# type 'a t = Leaf of 'a | Node of ('a * 'a) t
-#   val depth : 'a t -> int = <fun>
-#     Characters 34-74:
-    function Leaf _ -> 1 | Node x -> 1 + d x
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a t -> int which is less general than
-         'a0. 'a0 t -> int
-#   Characters 34-78:
-    function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type int t -> int which is less general than
-         'a. 'a t -> int
-#   Characters 34-74:
-    function Leaf x -> x | Node x -> depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a t -> 'a which is less general than
-         'a0. 'a0 t -> 'a
-#   Characters 38-78:
-    function Leaf x -> x | Node x -> depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'b. 'b t -> 'b which is less general than
-         'a 'b. 'a t -> 'b
-#   val r : 'a list * '_b list ref = ([], {contents = []})
-val q : unit -> 'a list * '_b list ref = <fun>
-# val f : 'a -> 'a = <fun>
-# val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0
-# Characters 39-45:
-  let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
-                                         ^^^^^^
-Error: This expression has type [> `Int of int ]
-       but an expression was expected of type [< `Int of int ]
-       Types for tag `Int are incompatible
-#       type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
-val zero : t = {f = `Int 0}
-#   Characters 56-62:
-  let zero = {f = `Int 0} ;; (* fails *)
-                  ^^^^^^
-Error: This expression has type [> `Int of int ]
-       but an expression was expected of type [< `Int of int ]
-       Types for tag `Int are incompatible
-#       val id : 'a -> 'a = <fun>
-val neg : int -> bool -> int * bool = <fun>
-#                         type t = A of int | B of (int * t) list | C of (string * t) list
-val transf : (int -> t) -> t -> t = <fun>
-val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun>
-#         type t = { f : 'a. ('a list -> int) Lazy.t; }
-val l : t = {f = <lazy>}
-#     type t = { f : 'a. 'a -> unit; }
-# - : t = {f = <fun>}
-# Characters 19-20:
-  let f ?x y = y in {f};; (* fail *)
-                     ^
-Error: This field value has type unit -> unit which is less general than
-         'a. 'a -> unit
-#               module Polux :
-  sig
-    type 'par t = 'par
-    val ident : 'a -> 'a
-    class alias : object method alias : 'a t -> 'a end
-    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
-  end
-#       Exception: Pervasives.Exit.
-#   Exception: Pervasives.Exit.
-#   Exception: Pervasives.Exit.
-#       Characters 16-44:
-  type 'x t = < f : 'y. 'y t >;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of t, type 'y t should be 'x t
-#                   val using_match : bool -> int * ('a -> 'a) = <fun>
-#   - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
-# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
-#           val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = <obj>
-#     Characters 89-110:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-                                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
-       which is less general than 'x. 'a -> 'x
-#     Characters 104-125:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-                                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
-       which is less general than 'x. 'a -> 'x
-#     Characters 128-149:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-                                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
-       which is less general than 'x. 'a -> 'x
-#         Characters 94-97:
-    if b then x else M.A;;
-                     ^^^
-Error: This expression has type M.t but an expression was expected of type 'x
-       The type constructor M.t would escape its scope
-# 

diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference
deleted file mode 100644 (file)
index fd96811..0000000
--- a/testsuite/tests/typing-poly/poly.ml.reference
+++ /dev/null
@@ -1,629 +0,0 @@
-
-# * * *       #   type 'a t = { t : 'a; }
-# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
-# val f : 'a list -> 'a fold = <fun>
-# - : int = 6
-#               class ['b] ilist :
-  'b list ->
-  object ('c)
-    val l : 'b list
-    method add : 'b -> 'c
-    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
-  end
-#         class virtual ['a] vlist :
-  object ('c)
-    method virtual add : 'a -> 'c
-    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#             class ilist2 :
-  int list ->
-  object ('a)
-    val l : int list
-    method add : int -> 'a
-    method fold : f:('b -> int -> 'b) -> init:'b -> 'b
-  end
-#             val ilist2 : 'a list -> 'a vlist = <fun>
-#             class ['a] ilist3 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#               class ['a] ilist4 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#                 class ['a] ilist5 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#                 class ['a] ilist6 :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method add : 'a -> 'c
-    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
-    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
-  end
-#       class virtual ['a] olist :
-  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
-#         class ['a] onil :
-  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
-#             class ['a] ocons :
-  hd:'a ->
-  tl:'a olist ->
-  object
-    val hd : 'a
-    val tl : 'a olist
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-  end
-#               class ['a] ostream :
-  hd:'a ->
-  tl:'a ostream ->
-  object
-    val hd : 'a
-    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
-    method empty : bool
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-  end
-#                   class ['a] ostream1 :
-  hd:'a ->
-  tl:'b ->
-  object ('b)
-    val hd : 'a
-    val tl : 'b
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
-    method hd : 'a
-    method tl : 'b
-  end
-#           class vari : object method m : [< `A | `B | `C ] -> int end
-#       class vari : object method m : [< `A | `B | `C ] -> int end
-#           module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
-#         class varj : object method m : [< V.v ] -> int end
-#         module type T =
-  sig class vari : object method m : [< `A | `B | `C ] -> int end end
-#             module M0 :
-  sig class vari : object method m : [< `A | `B | `C ] -> int end end
-#   module M : T
-# val v : M.vari = <obj>
-# - : int = 1
-#               class point :
-  x:int ->
-  y:int -> object val x : int val y : int method x : int method y : int end
-#           class color_point :
-  x:int ->
-  y:int ->
-  color:string ->
-  object
-    val color : string
-    val x : int
-    val y : int
-    method color : string
-    method x : int
-    method y : int
-  end
-#                   class circle :
-  #point ->
-  r:int ->
-  object val p : point val r : int method distance : #point -> float end
-#           val p0 : point = <obj>
-val p1 : point = <obj>
-val cp : color_point = <obj>
-val c : circle = <obj>
-val d : float = 11.
-#   val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
-#   Characters 41-42:
-  let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
-                                           ^
-Error: This expression has type < m : 'b. 'b -> 'b list >
-       but an expression was expected of type < m : 'b. 'b -> 'c >
-       The universal variable 'b would escape its scope
-#           class id : object method id : 'a -> 'a end
-#         class type id_spec = object method id : 'a -> 'a end
-#       class id_impl : object method id : 'a -> 'a end
-#               class a : object method m : bool end
-and b : object method id : 'a -> 'a end
-#           Characters 72-77:
-    method id x = x
-              ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-#         Characters 75-80:
-    method id x = x
-              ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
-#           Characters 80-85:
-    method id _ = x
-              ^^^^^
-Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
-#                 Characters 92-159:
-  ............x =
-      match r with
-        None -> r <- Some x; x
-      | Some y -> y
-Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
-#         class c : object method m : 'a -> 'b -> 'a end
-#     val f1 : id -> int * bool = <fun>
-#   val f2 : id -> int * bool = <fun>
-#   Characters 24-28:
-  let f3 f = f#id 1, f#id true
-                          ^^^^
-Error: This expression has type bool but an expression was expected of type
-         int
-#   val f4 : id -> int * bool = <fun>
-#           class c : object method m : #id -> int * bool end
-#             class id2 : object method id : 'a -> 'a method mono : int -> int end
-#   val app : int * bool = (1, true)
-#   Characters 0-25:
-  type 'a foo = 'a foo list
-  ^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: The type abbreviation foo is cyclic
-#     class ['a] bar : 'a -> object  end
-#   type 'a foo = 'a foo bar
-#   - : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = <fun>
-# - : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = <fun>
-# val f :
-  (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
-  'a * (< n : 'c; .. > as 'c) = <fun>
-# - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
-    (< m : 'c; n : 'a; .. > as 'c)
-= <fun>
-# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
-    ('f * < p : 'b. 'b * 'e * 'c > as 'e)
-= <fun>
-#   - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = <fun>
-#   type sum = T of < id : 'a. 'a -> 'a >
-# - : sum -> 'a -> 'a = <fun>
-#   type record = { r : < id : 'a. 'a -> 'a >; }
-# - : record -> 'a -> 'a = <fun>
-# - : record -> 'a -> 'a = <fun>
-#       class myself : object ('b) method self : 'a -> 'b end
-#                       class number :
-  object ('b)
-    val num : int
-    method num : int
-    method prev : 'b
-    method succ : 'b
-    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
-  end
-#     val id : 'a -> 'a = <fun>
-#       class c : object method id : 'a -> 'a end
-#         class c' : object method id : 'a -> 'a end
-#               class d :
-  object
-    val mutable count : int
-    method count : int
-    method id : 'a -> 'a
-    method old : 'a -> 'a
-  end
-#             class ['a] olist :
-  'a list ->
-  object ('c)
-    val l : 'a list
-    method cons : 'a -> 'c
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
-  end
-#   val sum : int #olist -> int = <fun>
-#   val count : 'a #olist -> int = <fun>
-#     val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
-#     type 'a t = unit
-#   class o : object method x : [> `A ] t -> unit end
-#   class c : object method m : d end
-and d : ?x:int -> unit -> object  end
-# class d : ?x:int -> unit -> object  end
-and c : object method m : d end
-#           class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
-class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
-class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
-#       class type node_type = object method as_variant : [> `Node of node_type ] end
-#       class node : node_type
-#     class node : object method as_variant : [> `Node of node_type ] end
-#   type bad = { bad : 'a. 'a option ref; }
-# Characters 17-25:
-  let bad = {bad = ref None};;
-                   ^^^^^^^^
-Error: This field value has type 'b option ref which is less general than
-         'a. 'a option ref
-# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
-# val bad2 : bad2 = {bad2 = None}
-# Characters 13-28:
-  bad2.bad2 <- Some (ref None);;
-               ^^^^^^^^^^^^^^^
-Error: This field value has type 'b option ref option
-       which is less general than 'a. 'a option ref option
-#       val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = <fun>
-# val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = <fun>
-#       type 'a t = [ `A of 'a ]
-#       class c : object method m : ([> 'a t ] as 'a) -> unit end
-#         class c : object method m : ([> 'a t ] as 'a) -> unit end
-#     class c : object method m : ([> 'a t ] as 'a) -> 'a end
-#     class c : object method m : ([> `A ] as 'a) option -> 'a end
-#           Characters 145-166:
-  object method virtual visit : 'a.('a visitor -> 'a) end;;
-                                ^^^^^^^^^^^^^^^^^^^^^
-Error: The universal type variable 'a cannot be generalized:
-       it escapes its scope.
-#                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
-class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
-type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
-#     Characters 15-25:
-  type t = u and u = t;;
-  ^^^^^^^^^^
-Error: The type abbreviation t is cyclic
-#       class ['a] a : object constraint 'a = [> `A of 'a a ] end
-type t = [ `A of t a ]
-#     Characters 71-80:
-  type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
-                                                    ^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type ('a, 'b) t should be an instance of ('c, 'c) t
-#     type 'a t = 'a
-and u = int t
-#     type 'a t constraint 'a = int
-# Characters 26-32:
-  type 'a u = 'a and 'a v = 'a u t;;
-                            ^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type 'a u t should be an instance of int t
-# type 'a u = 'a constraint 'a = int
-and 'a v = 'a u t constraint 'a = int
-#     type g = int
-# type 'a t = unit constraint 'a = g
-# Characters 26-32:
-  type 'a u = 'a and 'a v = 'a u t;;
-                            ^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type 'a u t should be an instance of g t
-# type 'a u = 'a constraint 'a = g
-and 'a v = 'a u t constraint 'a = g
-#     Characters 34-58:
-  type 'a u = < m : 'a v > and 'a v = 'a list u;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of v, type 'a list u should be 'a u
-#       type 'a t = 'a
-type 'a u = A of 'a t
-#     type 'a t = < a : 'a >
-# - : ('a t as 'a) -> 'a t = <fun>
-# type u = 'a t as 'a
-#       type t = A | B
-# - : [> `A ] * t -> int = <fun>
-# - : [> `A ] * t -> int = <fun>
-# - : [> `A ] option * t -> int = <fun>
-#   - : [> `A ] option * t -> int = <fun>
-# - : t * [< `A | `B ] -> int = <fun>
-# - : [< `A | `B ] * t -> int = <fun>
-# Characters 0-41:
-  function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(`AnyExtraTag, `AnyExtraTag)
-- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
-# Characters 0-29:
-  function `B,1 -> 1 | _,1 -> 2;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(_, 0)
-Characters 21-24:
-  function `B,1 -> 1 | _,1 -> 2;;
-                       ^^^
-Warning 11: this match case is unused.
-- : [< `B ] * int -> int = <fun>
-# Characters 0-29:
-  function 1,`B -> 1 | 1,_ -> 2;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
-(0, _)
-Characters 21-24:
-  function 1,`B -> 1 | 1,_ -> 2;;
-                       ^^^
-Warning 11: this match case is unused.
-- : int * [< `B ] -> int = <fun>
-#       Characters 64-135:
-  type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Constraints are not satisfied in this type.
-       Type
-       ([> `B of 'a ], 'a) b as 'a
-       should be an instance of
-       (('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
-#     *               class type ['a, 'b] a =
-  object
-    constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
-    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
-    method as_a : 'c
-    method b : 'b
-  end
-and ['a, 'b] b =
-  object
-    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
-    constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
-    method a : 'a
-    method as_b : ('a, 'b) b
-  end
-#   class type ['a] ca =
-  object ('b)
-    constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
-    method as_a : ('b, 'a) a
-    method b : 'a
-  end
-# class type ['a] cb =
-  object ('b)
-    constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
-    method a : 'a
-    method as_b : ('a, 'b) b
-  end
-#     type bt = 'a ca cb as 'a
-#     class c : object method m : int end
-# val f : unit -> c = <fun>
-# val f : unit -> c = <fun>
-# Characters 11-60:
-  let f () = object method private n = 1 method m = {<>}#n end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 15: the following private methods were made public implicitly:
- n.
-val f : unit -> < m : int; n : int > = <fun>
-# Characters 11-56:
-  let f () = object (self:c) method n = 1 method m = 2 end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type c but actually has type
-         < m : int; n : 'a >
-       The first object type has no method n
-# Characters 11-69:
-  let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type < n : int > but actually has type
-         < m : 'a >
-       The second object type has no method n
-#         Characters 66-124:
-      object (self: 's) method x = 3 method private m = self end
-      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This object is expected to have type < x : int; .. >
-       but actually has type < x : int >
-       Self type cannot be unified with a closed object type
-#         val o : < x : int > = <obj>
-#         Characters 76-77:
-    (x : <m : 'a. 'a * (<m:'b. 'a * <m:'c. 'c * 'bar> > as 'bar) >);;
-     ^
-Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
-       but an expression was expected of type
-         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
-       Types for method m are incompatible
-#         Characters 176-177:
-  let f (x : foo') = (x : bar');;
-                      ^
-Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
-       but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
-       Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > 
-       Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         < m : 'c. 'c * 'a bar > 
-       Types for method m are incompatible
-#     Characters 67-68:
-    (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('c * 'bar)>)> as 'bar);;
-     ^
-Error: This expression has type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
-       Types for method m are incompatible
-#   Characters 66-67:
-    (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('b * 'bar)>)> as 'bar);;
-     ^
-Error: This expression has type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
-       Types for method m are incompatible
-#   Characters 51-52:
-    (x : <m : 'b. 'b * ('b * <m:'c. 'c * 'bar> as 'bar)>);;
-     ^
-Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
-       but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
-       Types for method m are incompatible
-#     Characters 14-115:
-  ....(x : <m : 'a. 'a -> ('a * <m:'c. 'c -> 'bar> as 'bar)>
-         :> <m : 'a. 'a -> ('a * 'foo)> as 'foo)..
-Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
-       is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f 
-       Type 'c. 'e is not a subtype of 'a. 'g 
-#       Characters 88-150:
-  = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       ...
-       Values do not match:
-         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
-       is not included in
-         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
-#     Characters 78-132:
-  = struct type t = <m : 'a. 'a * ('a * 'foo)> as 'foo end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
-       is not included in
-         sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
-       Type declarations do not match:
-         type t = < m : 'a. 'a * ('a * 'b) > as 'b
-       is not included in
-         type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
-#     module M : sig type 'a t type u = < m : 'a. 'a t > end
-#   module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
-#     module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
-#         val f :
-  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
-  'b -> bool = <fun>
-#         type t = [ `A | `B ]
-# type v = private [> t ]
-# - : t -> v = <fun>
-# type u = private [< t ]
-# - : u -> v = <fun>
-# Characters 9-21:
-  fun x -> (x : v :> u);;
-           ^^^^^^^^^^^^
-Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ] 
-# type v = private [< t ]
-# Characters 9-21:
-  fun x -> (x : u :> v);;
-           ^^^^^^^^^^^^
-Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ] 
-# type p = < x : p >
-# type q = private < x : p; .. >
-# - : q -> p = <fun>
-# Characters 9-21:
-  fun x -> (x : p :> q);;
-           ^^^^^^^^^^^^
-Error: Type p = < x : p > is not a subtype of q = < x : p; .. > 
-#       Characters 14-100:
-  ..(x : <m:'a. (<p:int;..> as 'a) -> int>
-      :> <m:'b. (<p:int;q:int;..> as 'b) -> int>)..
-Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
-         < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
-       Type < p : int; q : int; .. > as 'c is not a subtype of
-         < p : int; .. > as 'd 
-#     val f2 :
-  < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
-  < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun>
-#     Characters 13-107:
-  ..(x : <m:'a. (<p:<a:int;b:int>;..> as 'a) -> int>
-      :> <m:'b. (<p:<a:int>;..> as 'b) -> int>)..
-Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
-       is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
-       Type < a : int > is not a subtype of < a : int; b : int > 
-# Characters 11-55:
-  let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);;
-             ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type < p : < a : int; b : int >; .. > is not a subtype of
-         < p : < a : int >; .. > 
-       The second object type has no method b
-#   val f5 :
-  < m : 'a. [< `A of < p : int > ] as 'a > ->
-  < m : 'b. [< `A of <  > ] as 'b > = <fun>
-#   Characters 13-83:
-    (x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
-         < m : 'b. [< `A of < p : int > ] as 'b > 
-       Type <  > is not a subtype of < p : int > 
-#     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
-# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
-# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
-# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
-# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
-# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
-#     class c : object method id : 'a -> 'a end
-# type u = c option
-# val just : 'a option -> 'a = <fun>
-# val f : c -> 'a -> 'a = <fun>
-#     val g : c -> 'a -> 'a = <fun>
-#     val h : < id : 'a; .. > -> 'a = <fun>
-#     type 'a u = c option
-# val just : 'a option -> 'a = <fun>
-# val f : c -> 'a -> 'a = <fun>
-#       val f : 'a -> int = <fun>
-val g : 'a -> int = <fun>
-# type 'a t = Leaf of 'a | Node of ('a * 'a) t
-#   val depth : 'a t -> int = <fun>
-#     Characters 34-74:
-    function Leaf _ -> 1 | Node x -> 1 + d x
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a t -> int which is less general than
-         'a0. 'a0 t -> int
-#   Characters 34-78:
-    function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type int t -> int which is less general than
-         'a. 'a t -> int
-#   Characters 34-74:
-    function Leaf x -> x | Node x -> depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a t -> 'a which is less general than
-         'a0. 'a0 t -> 'a
-#   Characters 38-78:
-    function Leaf x -> x | Node x -> depth x;; (* fails *)
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'b. 'b t -> 'b which is less general than
-         'a 'b. 'a t -> 'b
-#   val r : 'a list * '_b list ref = ([], {contents = []})
-val q : unit -> 'a list * '_b list ref = <fun>
-# val f : 'a -> 'a = <fun>
-# val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0
-# Characters 39-45:
-  let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
-                                         ^^^^^^
-Error: This expression has type [> `Int of int ]
-       but an expression was expected of type [< `Int of int ]
-       Types for tag `Int are incompatible
-#       type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
-val zero : t = {f = `Int 0}
-#   Characters 56-62:
-  let zero = {f = `Int 0} ;; (* fails *)
-                  ^^^^^^
-Error: This expression has type [> `Int of int ]
-       but an expression was expected of type [< `Int of int ]
-       Types for tag `Int are incompatible
-#       val id : 'a -> 'a = <fun>
-val neg : int -> bool -> int * bool = <fun>
-#                         type t = A of int | B of (int * t) list | C of (string * t) list
-val transf : (int -> t) -> t -> t = <fun>
-val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun>
-#         type t = { f : 'a. ('a list -> int) Lazy.t; }
-val l : t = {f = <lazy>}
-#     type t = { f : 'a. 'a -> unit; }
-# - : t = {f = <fun>}
-# Characters 19-20:
-  let f ?x y = y in {f};; (* fail *)
-                     ^
-Error: This field value has type unit -> unit which is less general than
-         'a. 'a -> unit
-#               module Polux :
-  sig
-    type 'par t = 'par
-    val ident : 'a -> 'a
-    class alias : object method alias : 'a t -> 'a end
-    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
-  end
-#       Exception: Pervasives.Exit.
-#   Exception: Pervasives.Exit.
-#   Exception: Pervasives.Exit.
-#       Characters 16-44:
-  type 'x t = < f : 'y. 'y t >;;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: In the definition of t, type 'y t should be 'x t
-#                   val using_match : bool -> int * ('a -> 'a) = <fun>
-#   - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
-# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
-#           val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = <obj>
-#     val n : < m : 'x. [< `Foo of 'x ] -> 'x > = <obj>
-#     Characters 59-129:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
-       but an expression was expected of type
-         < m : 'a. [< `Foo of int ] -> 'a >
-       The universal variable 'x would escape its scope
-#     Characters 83-153:
-    object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
-       but an expression was expected of type
-         < m : 'a. [< `Foo of int ] -> 'a >
-       The universal variable 'x would escape its scope
-#         Characters 94-97:
-    if b then x else M.A;;
-                     ^^^
-Error: This expression has type M.t but an expression was expected of type 'x
-       The type constructor M.t would escape its scope
-# 

diff --git a/testsuite/tests/typing-safe-linking/Makefile b/testsuite/tests/typing-safe-linking/Makefile
index a1e8aba8c5eecae6f61a914e67fc9e277d30eefb..4e3cf43a5e5348c925acf944e89a9a99a6f87dbd 100644 (file)
--- a/testsuite/tests/typing-safe-linking/Makefile
+++ b/testsuite/tests/typing-safe-linking/Makefile
@@ -5,7 +5,7 @@ OBJECTS = $(SOURCES:%.ml=%.cmo)
 
 all: a.cmo
        @printf " ... testing 'b_bad.ml'"
-       @$(OCAMLC) -c -safe-string -warn-error +8 b_bad.ml 2> /dev/null \
+       @$(OCAMLC) $(ADD_COMPFLAGS) -c -safe-string -warn-error +8 b_bad.ml 2> /dev/null \
         && echo " => failed" || echo " => passed"
 
 clean:
@@ -13,3 +13,8 @@ clean:
 
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.common
+
+# The second test (`A.y`) is unnecessary, indeed cannot be compiled, under -safe-string
+ifeq ($(SAFE_STRING),true)
+ADD_COMPFLAGS=-pp "sed -e '\$$d'"
+endif

diff --git a/testsuite/tests/typing-safe-linking/a.ml b/testsuite/tests/typing-safe-linking/a.ml
index 6c4ca42e7cec79a9c217a0784e46f0f398514078..12e0cb123b248ab7f94d274ad9eb819a43dc350d 100644 (file)
--- a/testsuite/tests/typing-safe-linking/a.ml
+++ b/testsuite/tests/typing-safe-linking/a.ml
@@ -2,4 +2,5 @@
      X of string
    | Y : bytes t
 
+(* It is important that the line below is the last line of the file (see Makefile) *)
 let y : string t = Y

diff --git a/testsuite/tests/typing-safe-linking/b_bad.ml b/testsuite/tests/typing-safe-linking/b_bad.ml
index 8730dcbdd2694274be170f7d99ed9196397e5e5d..6615070a2a614c68fdf83e5cc2ece8fcdb8a1f46 100644 (file)
--- a/testsuite/tests/typing-safe-linking/b_bad.ml
+++ b/testsuite/tests/typing-safe-linking/b_bad.ml
@@ -1,4 +1,5 @@
 let f : string A.t -> unit = function
     A.X s -> print_endline s
 
+(* It is important that the line below is the last line of the file (see Makefile) *)
 let () = f A.y

diff --git a/testsuite/tests/typing-unboxed-types/Makefile b/testsuite/tests/typing-unboxed-types/Makefile
new file mode 100644 (file)
index 0000000..9625a3f
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml
new file mode 100644 (file)
index 0000000..f187b76
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test.ml
@@ -0,0 +1,121 @@
+(* Check the unboxing *)
+
+(* For concrete types *)
+type t1 = A of string [@@ocaml.unboxed];;
+
+let x = A "foo" in
+Obj.repr x == Obj.repr (match x with A s -> s)
+;;
+
+(* For records *)
+type t2 = { f : string } [@@ocaml.unboxed];;
+
+let x = { f = "foo" } in
+Obj.repr x == Obj.repr x.f
+;;
+
+(* For inline records *)
+type t3 = B of { g : string } [@@ocaml.unboxed];;
+
+let x = B { g = "foo" } in
+Obj.repr x == Obj.repr (match x with B {g} -> g)
+;;
+
+(* Check unboxable types *)
+type t4 = C [@@ocaml.unboxed];;  (* no argument *)
+type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
+type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
+type t6 = G of int | H [@@ocaml.unboxed];;
+type t7 = I of string | J of bool [@@ocaml.unboxed];;
+
+type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
+type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
+
+(* let rec must be rejected *)
+type t10 = A of t10 [@@ocaml.unboxed];;
+let rec x = A x;;
+
+(* Representation mismatch between module and signature must be rejected *)
+module M : sig
+  type t = A of string
+end = struct
+  type t = A of string [@@ocaml.unboxed]
+end;;
+
+module N : sig
+  type t = A of string [@@ocaml.unboxed]
+end = struct
+  type t = A of string
+end;;
+
+module O : sig
+  type t = { f : string }
+end = struct
+  type t = { f : string } [@@ocaml.unboxed]
+end;;
+
+module P : sig
+  type t = { f : string } [@@ocaml.unboxed]
+end = struct
+  type t = { f : string }
+end;;
+
+module Q : sig
+  type t = A of { f : string }
+end = struct
+  type t = A of { f : string } [@@ocaml.unboxed]
+end;;
+
+module R : sig
+  type t = A of { f : string } [@@ocaml.unboxed]
+end = struct
+  type t = A of { f : string }
+end;;
+
+
+(* Check interference with representation of float arrays. *)
+type t11 = L of float [@@ocaml.unboxed];;
+let x = Array.make 10 (L 3.14)   (* represented as a flat array *)
+and f (a : t11 array) = a.(0)    (* might wrongly assume an array of pointers *)
+in assert (f x = L 3.14);;
+
+
+(* Check for a potential infinite loop in the typing algorithm. *)
+type 'a t12 = M of 'a t12 [@@ocaml.unboxed];;
+let f (a : int t12 array) = a.(0);;
+
+(* Check for another possible loop *)
+type t13 = A : _ t12 -> t13 [@@ocaml.unboxed];;
+
+
+
+(* should work *)
+type t14;;
+type t15 = A of t14 [@@ocaml.unboxed];;
+
+(* should fail *)
+type 'a abs;;
+type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
+
+(* should work *)
+type t18 = A : _ list abs -> t18 [@@ocaml.unboxed];;
+
+(* should fail because the compiler knows that t is actually float and
+   optimizes the record's representation *)
+module S : sig
+  type t
+  type u = { f1 : t; f2 : t }
+end = struct
+  type t = A of float [@@ocaml.unboxed]
+  type u = { f1 : t; f2 : t }
+end;;
+
+
+(* implementing [@@immediate] with [@@ocaml.unboxed]: this works because the
+   representation of [t] is [int]
+ *)
+module T : sig
+  type t [@@immediate]
+end = struct
+  type t = A of int [@@ocaml.unboxed]
+end;;

diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference b/testsuite/tests/typing-unboxed-types/test.ml.reference
new file mode 100644 (file)
index 0000000..b555db8
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference
@@ -0,0 +1,162 @@
+
+#       type t1 = A of string [@@unboxed]
+#       - : bool = true
+#     type t2 = { f : string; } [@@unboxed]
+#       - : bool = true
+#     type t3 = B of { g : string; } [@@unboxed]
+#       - : bool = true
+#     Characters 29-58:
+  type t4 = C [@@ocaml.unboxed];;  (* no argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because its constructor has no argument.
+# Characters 0-45:
+  type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+# Characters 0-33:
+  type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-40:
+  type t6 = G of int | H [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-51:
+  type t7 = I of string | J of bool [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+#   Characters 1-50:
+  type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one field.
+# Characters 0-56:
+  type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+#     type t10 = A of t10 [@@unboxed]
+# Characters 12-15:
+  let rec x = A x;;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#             Characters 121-172:
+  ......struct
+    type t = A of string [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string [@@unboxed] end
+       is not included in
+         sig type t = A of string end
+       Type declarations do not match:
+         type t = A of string [@@unboxed]
+       is not included in
+         type t = A of string
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 63-96:
+  ......struct
+    type t = A of string
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string end
+       is not included in
+         sig type t = A of string [@@unboxed] end
+       Type declarations do not match:
+         type t = A of string
+       is not included in
+         type t = A of string [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 48-102:
+  ......struct
+    type t = { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = { f : string; } end
+       Type declarations do not match:
+         type t = { f : string; } [@@unboxed]
+       is not included in
+         type t = { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 66-102:
+  ......struct
+    type t = { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } end
+       is not included in
+         sig type t = { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = { f : string; }
+       is not included in
+         type t = { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 53-112:
+  ......struct
+    type t = A of { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = A of { f : string; } end
+       Type declarations do not match:
+         type t = A of { f : string; } [@@unboxed]
+       is not included in
+         type t = A of { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 71-112:
+  ......struct
+    type t = A of { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } end
+       is not included in
+         sig type t = A of { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = A of { f : string; }
+       is not included in
+         type t = A of { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#       type t11 = L of float [@@unboxed]
+#     - : unit = ()
+#       type 'a t12 = M of 'a t12 [@@unboxed]
+# val f : int t12 array -> int t12 = <fun>
+#     type t13 = A : 'a t12 -> t13 [@@unboxed]
+#         type t14
+# type t15 = A of t14 [@@unboxed]
+#     type 'a abs
+# Characters 0-45:
+  type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#     type t18 = A : 'a list abs -> t18 [@@unboxed]
+#   *               Characters 176-256:
+  ......struct
+    type t = A of float [@@ocaml.unboxed]
+    type u = { f1 : t; f2 : t }
+  end..
+Error: Signature mismatch:
+       ...
+       Type declarations do not match:
+         type u = { f1 : t; f2 : t; }
+       is not included in
+         type u = { f1 : t; f2 : t; }
+       Their internal representations differ:
+       the first declaration uses unboxed float representation.
+#     * *           module T : sig type t [@@immediate] end
+# 

diff --git a/testsuite/tests/typing-warnings/Makefile b/testsuite/tests/typing-warnings/Makefile
index fd7f751cd85682afd44190fbb55fbf1ed8bf43d0..646c8d497aefc26a022ed269e9663969705cb325 100644 (file)
--- a/testsuite/tests/typing-warnings/Makefile
+++ b/testsuite/tests/typing-warnings/Makefile
@@ -16,4 +16,4 @@
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
-TOPFLAGS = -w A
+TOPFLAGS = -w A -strict-sequence

diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml b/testsuite/tests/typing-warnings/exhaustiveness.ml
index 2ddb79d31469928ea6671652c7d2edc158426801..d3d9bc05b0f3dafa04f7ef729e914241c9584faa 100644 (file)
--- a/testsuite/tests/typing-warnings/exhaustiveness.ml
+++ b/testsuite/tests/typing-warnings/exhaustiveness.ml
@@ -32,7 +32,8 @@ type 'a pair = {left: 'a; right: 'a};;
 
 let f : (int t box pair * bool) option -> unit = function None -> ();;
 let f : (string t box pair * bool) option -> unit = function None -> ();;
-
+let f = function {left=Box 0; _ } -> ();;
+let f = function {left=Box 0;right=Box 1} -> ();;
 
 (* Examples from ML2015 paper *)
 

diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
index e19efbb0ad9a0c0d8cdd0450799777b12b764425..4935f6904209d9ca21c78705528c5daaa64f0236 100644 (file)
--- a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
+++ b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference
@@ -4,7 +4,7 @@
       None, None -> 1
     | Some _, Some _ -> 2..
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 ((Some _, None)|(None, Some _))
 val f : 'a option * 'b option -> int = <fun>
 #             type _ t = A : int t | B : bool t | C : char t | D : float t
@@ -14,7 +14,7 @@ type v = E | F | G
   .function A, A, A, A, A, A, A, _, U, U -> 1
      | _, _, _, _, _, _, _, G, _, _ -> 1
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 (A, A, A, A, A, A, B, (E|F), _, _)
 Characters 172-200:
      | _, _, _, _, _, _, _, G, _, _ -> 1
@@ -52,7 +52,7 @@ val f : unit t option -> int = <fun>
   let f (x : int t option) = match x with None -> 1;; (* warn *)
                              ^^^^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some A
 val f : int t option -> int = <fun>
 #         type 'a box = Box of 'a
@@ -61,11 +61,25 @@ type 'a pair = { left : 'a; right : 'a; }
   let f : (int t box pair * bool) option -> unit = function None -> ();;
                                                    ^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some ({left=Box A; right=Box A}, _)
 val f : (int t box pair * bool) option -> unit = <fun>
 # val f : (string t box pair * bool) option -> unit = <fun>
-#               type _ t = Int : int t | Bool : bool t
+# Characters 8-39:
+  let f = function {left=Box 0; _ } -> ();;
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=Box 1; _ }
+val f : int box pair -> unit = <fun>
+# Characters 8-47:
+  let f = function {left=Box 0;right=Box 1} -> ();;
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+{left=Box 0; right=Box 0}
+val f : int box pair -> unit = <fun>
+#             type _ t = Int : int t | Bool : bool t
 #         val f : 'a t -> 'a = <fun>
 #     val g : int t -> int = <fun>
 #         val h : 'a t -> 'a t -> bool = <fun>
@@ -75,7 +89,7 @@ module A : sig type a type b val eq : (a, b) cmp end
   let f : (A.a, A.b) cmp -> unit = function Any -> ()
                                    ^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Eq
 val f : (A.a, A.b) cmp -> unit = <fun>
 #     val deep : char t option -> char = <fun>
@@ -90,7 +104,7 @@ type _ succ = Succ
     function None -> false
     ^^^^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some (PlusS _)
 val harder : (zero succ, zero succ, zero succ) plus option -> bool = <fun>
 #     val harder : (zero succ, zero succ, zero succ) plus option -> bool = <fun>

diff --git a/testsuite/tests/typing-warnings/pr5892.ml.reference b/testsuite/tests/typing-warnings/pr5892.ml.reference
index 1321634aff2c4cc40cc1c07d7b6f8b5ea9ea78e3..e56687afd83eb223176f13f3fcff0942ebcd8c10 100644 (file)
--- a/testsuite/tests/typing-warnings/pr5892.ml.reference
+++ b/testsuite/tests/typing-warnings/pr5892.ml.reference
@@ -6,7 +6,7 @@
   let f : label choice -> bool = function Left -> true;; (* warn *)
                                  ^^^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Right
 val f : CamlinternalOO.label choice -> bool = <fun>
 # 

diff --git a/testsuite/tests/typing-warnings/pr6872.ml.principal.reference b/testsuite/tests/typing-warnings/pr6872.ml.principal.reference
index 097e34f97865300f37b39b0a60ee9c3f2b33bf11..eaebf2253f60a9e225bf121f686e31547e8380e2 100644 (file)
--- a/testsuite/tests/typing-warnings/pr6872.ml.principal.reference
+++ b/testsuite/tests/typing-warnings/pr6872.ml.principal.reference
@@ -10,7 +10,8 @@ The first one was selected. Please disambiguate if this is wrong.
 # Characters 6-7:
   raise A;;
         ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Exception: A.
 # - : a -> unit = <fun>
 # Characters 26-27:
@@ -26,10 +27,12 @@ Error: This pattern matches values of type a
 # Characters 10-11:
   try raise A with A -> 2;;
             ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 17-18:
   try raise A with A -> 2;;
                    ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 - : int = 2
 # 

diff --git a/testsuite/tests/typing-warnings/pr6872.ml.reference b/testsuite/tests/typing-warnings/pr6872.ml.reference
index 072ccb4daa7398292800b108908ac78c48520566..7c0b3503828193ef03bbc702d54d1faceee6775c 100644 (file)
--- a/testsuite/tests/typing-warnings/pr6872.ml.reference
+++ b/testsuite/tests/typing-warnings/pr6872.ml.reference
@@ -10,21 +10,25 @@ The first one was selected. Please disambiguate if this is wrong.
 # Characters 6-7:
   raise A;;
         ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Exception: A.
 # - : a -> unit = <fun>
 # Characters 26-27:
   function Not_found -> 1 | A -> 2 | _ -> 3;;
                             ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 - : exn -> int = <fun>
 # Characters 10-11:
   try raise A with A -> 2;;
             ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 17-18:
   try raise A with A -> 2;;
                    ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 - : int = 2
 # 

diff --git a/testsuite/tests/typing-warnings/pr7085.ml.reference b/testsuite/tests/typing-warnings/pr7085.ml.reference
index 960ccaff059f096b402791e6d46ed97f09001758..3a54d4ad7642fcda6479a57eed9cd953bde63c83 100644 (file)
--- a/testsuite/tests/typing-warnings/pr7085.ml.reference
+++ b/testsuite/tests/typing-warnings/pr7085.ml.reference
@@ -3,7 +3,7 @@
        match M.is_t () with None -> 0
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 Some (Is Eq)
 module TypEq : sig type (_, _) t = Eq : ('a, 'a) t end
 module type T =

diff --git a/testsuite/tests/typing-warnings/pr7297.ml b/testsuite/tests/typing-warnings/pr7297.ml
new file mode 100644 (file)
index 0000000..64b6fd5
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7297.ml
@@ -0,0 +1 @@
+let () = raise Exit; () ;; (* warn *)

diff --git a/testsuite/tests/typing-warnings/pr7297.ml.reference b/testsuite/tests/typing-warnings/pr7297.ml.reference
new file mode 100644 (file)
index 0000000..9c9dbdd
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7297.ml.reference
@@ -0,0 +1,7 @@
+
+# Characters 9-19:
+  let () = raise Exit; () ;; (* warn *)
+           ^^^^^^^^^^
+Warning 21: this statement never returns (or has an unsound type.)
+Exception: Pervasives.Exit.
+# 

diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference
index c208dee25dfa0738d178e874406adc1160621716..989fce35199ecc3f7b59c3bc74542fcef4e19772 100644 (file)
--- a/testsuite/tests/typing-warnings/records.ml.principal.reference
+++ b/testsuite/tests/typing-warnings/records.ml.principal.reference
@@ -4,7 +4,8 @@
 #                 Characters 49-50:
     let f1 (r:t) = r.x (* ok *)
                      ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 89-90:
     let f2 r = ignore (r:t); r.x (* non principal *)
                                ^
@@ -12,15 +13,18 @@ Warning 18: this type-based field disambiguation is not principal.
 Characters 89-90:
     let f2 r = ignore (r:t); r.x (* non principal *)
                                ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 148-149:
       match r with {x; y} -> y + y (* ok *)
                     ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 151-152:
       match r with {x; y} -> y + y (* ok *)
                        ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 148-149:
       match r with {x; y} -> y + y (* ok *)
                     ^
@@ -51,7 +55,8 @@ Error: This pattern matches values of type M1.u
 # Characters 18-21:
   let f (r:M.t) = r.M.x;; (* ok *)
                     ^^^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 val f : M.t -> int = <fun>
 # Characters 18-19:
   let f (r:M.t) = r.x;; (* warning *)
@@ -62,12 +67,14 @@ be selected if the type becomes unknown.
 Characters 18-19:
   let f (r:M.t) = r.x;; (* warning *)
                     ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 val f : M.t -> int = <fun>
 # Characters 8-9:
   let f ({x}:M.t) = x;; (* warning *)
           ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 7-10:
   let f ({x}:M.t) = x;; (* warning *)
          ^^^
@@ -80,7 +87,8 @@ val f : M.t -> int = <fun>
 #         Characters 57-58:
     let f (r:M.t) = r.x
                       ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 30-36:
     open N
     ^^^^^^
@@ -101,7 +109,8 @@ module OK : sig val f : M.t -> int end
 #       Characters 37-38:
     let f {x;z} = x,z
            ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 36-41:
     let f {x;z} = x,z
           ^^^^^
@@ -116,11 +125,13 @@ Error: Some record fields are undefined: y
 #           Characters 90-91:
     let r = {x=3; y=true}
              ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 95-96:
     let r = {x=3; y=true}
                   ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module OK :
   sig
     type u = { x : int; y : bool; }
@@ -172,7 +183,8 @@ Error: The record field NM.y belongs to the type NM.foo = M.foo
 #       Characters 65-66:
     let f r = ignore (r: foo); {r with x = 2; z = 3}
                                        ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 72-73:
     let f r = ignore (r: foo); {r with x = 2; z = 3}
                                               ^
@@ -187,7 +199,8 @@ Error: This record expression is expected to have type M.foo
 #       Characters 66-67:
     let f r = ignore (r: foo); { r with x = 3; a = 4 }
                                         ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 73-74:
     let f r = ignore (r: foo); { r with x = 3; a = 4 }
                                                ^
@@ -196,11 +209,13 @@ Error: This record expression is expected to have type M.foo
 #         Characters 39-40:
     let r = {x=1; y=2}
              ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 44-45:
     let r = {x=1; y=2}
                   ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 67-68:
     let r: other = {x=1; y=2}
                     ^
@@ -225,13 +240,15 @@ class f : t -> object  end
 # Characters 12-13:
   class g = f A;; (* ok *)
               ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 class g : f
 #   class f : 'a -> 'a -> object  end
 # Characters 13-14:
   class g = f (A : t) A;; (* warn with -principal *)
                ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 20-21:
   class g = f (A : t) A;; (* warn with -principal *)
                       ^
@@ -239,12 +256,14 @@ Warning 18: this type-based constructor disambiguation is not principal.
 Characters 20-21:
   class g = f (A : t) A;; (* warn with -principal *)
                       ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 class g : f
 #                       Characters 199-200:
     let y : t = {x = 0}
                  ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 114-120:
     open M  (* this open is unused, it isn't reported as shadowing 'x' *)
     ^^^^^^
@@ -273,7 +292,8 @@ module Shadow2 :
 #                 Characters 167-170:
     let f (u : u) = match u with `Key {loc} -> loc
                                        ^^^
-Warning 42: this use of loc required disambiguation.
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module P6235 :
   sig
     type t = { loc : string; }

diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference
index 2853439c6567e5fc30f7fd181911356f7a2dc9ad..349721e63889684d1e93703c2e084b482a172848 100644 (file)
--- a/testsuite/tests/typing-warnings/records.ml.reference
+++ b/testsuite/tests/typing-warnings/records.ml.reference
@@ -4,19 +4,23 @@
 #                 Characters 49-50:
     let f1 (r:t) = r.x (* ok *)
                      ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 89-90:
     let f2 r = ignore (r:t); r.x (* non principal *)
                                ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 148-149:
       match r with {x; y} -> y + y (* ok *)
                     ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 151-152:
       match r with {x; y} -> y + y (* ok *)
                        ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 148-149:
       match r with {x; y} -> y + y (* ok *)
                     ^
@@ -36,11 +40,13 @@ Error: This expression has type bool but an expression was expected of type
 #               Characters 86-87:
          {x; y} -> y + y
           ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 89-90:
          {x; y} -> y + y
              ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 86-87:
          {x; y} -> y + y
           ^
@@ -50,7 +56,8 @@ module F2 : sig val f : M1.t -> int end
 # Characters 18-21:
   let f (r:M.t) = r.M.x;; (* ok *)
                     ^^^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 val f : M.t -> int = <fun>
 # Characters 18-19:
   let f (r:M.t) = r.x;; (* warning *)
@@ -61,12 +68,14 @@ be selected if the type becomes unknown.
 Characters 18-19:
   let f (r:M.t) = r.x;; (* warning *)
                     ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 val f : M.t -> int = <fun>
 # Characters 8-9:
   let f ({x}:M.t) = x;; (* warning *)
           ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 7-10:
   let f ({x}:M.t) = x;; (* warning *)
          ^^^
@@ -79,7 +88,8 @@ val f : M.t -> int = <fun>
 #         Characters 57-58:
     let f (r:M.t) = r.x
                       ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 30-36:
     open N
     ^^^^^^
@@ -100,7 +110,8 @@ module OK : sig val f : M.t -> int end
 #       Characters 37-38:
     let f {x;z} = x,z
            ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 36-41:
     let f {x;z} = x,z
           ^^^^^
@@ -115,11 +126,13 @@ Error: Some record fields are undefined: y
 #           Characters 90-91:
     let r = {x=3; y=true}
              ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 95-96:
     let r = {x=3; y=true}
                   ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module OK :
   sig
     type u = { x : int; y : bool; }
@@ -171,7 +184,8 @@ Error: The record field NM.y belongs to the type NM.foo = M.foo
 #       Characters 65-66:
     let f r = ignore (r: foo); {r with x = 2; z = 3}
                                        ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 72-73:
     let f r = ignore (r: foo); {r with x = 2; z = 3}
                                               ^
@@ -186,7 +200,8 @@ Error: This record expression is expected to have type M.foo
 #       Characters 66-67:
     let f r = ignore (r: foo); { r with x = 3; a = 4 }
                                         ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 73-74:
     let f r = ignore (r: foo); { r with x = 3; a = 4 }
                                                ^
@@ -195,11 +210,13 @@ Error: This record expression is expected to have type M.foo
 #         Characters 39-40:
     let r = {x=1; y=2}
              ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 44-45:
     let r = {x=1; y=2}
                   ^
-Warning 42: this use of y required disambiguation.
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 67-68:
     let r: other = {x=1; y=2}
                     ^
@@ -224,22 +241,26 @@ class f : t -> object  end
 # Characters 12-13:
   class g = f A;; (* ok *)
               ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 class g : f
 #   class f : 'a -> 'a -> object  end
 # Characters 13-14:
   class g = f (A : t) A;; (* warn with -principal *)
                ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 20-21:
   class g = f (A : t) A;; (* warn with -principal *)
                       ^
-Warning 42: this use of A required disambiguation.
+Warning 42: this use of A relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 class g : f
 #                       Characters 199-200:
     let y : t = {x = 0}
                  ^
-Warning 42: this use of x required disambiguation.
+Warning 42: this use of x relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 Characters 114-120:
     open M  (* this open is unused, it isn't reported as shadowing 'x' *)
     ^^^^^^
@@ -268,7 +289,8 @@ module Shadow2 :
 #                 Characters 167-170:
     let f (u : u) = match u with `Key {loc} -> loc
                                        ^^^
-Warning 42: this use of loc required disambiguation.
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module P6235 :
   sig
     type t = { loc : string; }
@@ -279,7 +301,8 @@ module P6235 :
 #                     Characters 220-223:
       |`Key {loc} -> loc
              ^^^
-Warning 42: this use of loc required disambiguation.
+Warning 42: this use of loc relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
 module P6235' :
   sig
     type t = { loc : string; }

diff --git a/testsuite/tests/typing-warnings/unused_types.ml b/testsuite/tests/typing-warnings/unused_types.ml
index afe7d4cf167f4f59acd03fa67639767c7964785e..a8333abb806803812c165f8c85247cfb313d66d0 100644 (file)
--- a/testsuite/tests/typing-warnings/unused_types.ml
+++ b/testsuite/tests/typing-warnings/unused_types.ml
@@ -16,3 +16,55 @@ end = struct
   type unused = A of unused
 end
 ;;
+
+module Unused_exception : sig
+end = struct
+  exception Nobody_uses_me
+end
+;;
+
+module Unused_extension_constructor : sig
+  type t = ..
+end = struct
+  type t = ..
+  type t += Nobody_uses_me
+end
+;;
+
+module Unused_exception_outside_patterns : sig
+  val falsity : exn -> bool
+end = struct
+  exception Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_extension_outside_patterns : sig
+  type t = ..
+  val falsity : t -> bool
+end = struct
+  type t = ..
+  type t += Nobody_constructs_me
+  let falsity = function
+    | Nobody_constructs_me -> true
+    | _ -> false
+end
+;;
+
+module Unused_private_exception : sig
+  type exn += private Private_exn
+end = struct
+  exception Private_exn
+end
+;;
+
+module Unused_private_extension : sig
+  type t = ..
+  type t += private Private_ext
+end = struct
+  type t = ..
+  type t += Private_ext
+end
+;;

diff --git a/testsuite/tests/typing-warnings/unused_types.ml.reference b/testsuite/tests/typing-warnings/unused_types.ml.reference
index d515c24e4741f1170d252e39fb291b3f3ba3ddf1..9451ee696018d6a921e01f1c31bbcb6ffc03627e 100644 (file)
--- a/testsuite/tests/typing-warnings/unused_types.ml.reference
+++ b/testsuite/tests/typing-warnings/unused_types.ml.reference
@@ -18,4 +18,40 @@ Characters 40-65:
     ^^^^^^^^^^^^^^^^^^^^^^^^^
 Warning 37: unused constructor A.
 module Unused_rec : sig  end
+#           Characters 46-70:
+    exception Nobody_uses_me
+    ^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 38: unused exception Nobody_uses_me
+module Unused_exception : sig  end
+#               Characters 96-110:
+    type t += Nobody_uses_me
+              ^^^^^^^^^^^^^^
+Warning 38: unused extension constructor Nobody_uses_me
+module Unused_extension_constructor : sig type t = .. end
+#                   Characters 91-121:
+    exception Nobody_constructs_me
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 38: exception Nobody_constructs_me is never used to build values.
+(However, this constructor appears in patterns.)
+module Unused_exception_outside_patterns : sig val falsity : exn -> bool end
+#                       Characters 127-147:
+    type t += Nobody_constructs_me
+              ^^^^^^^^^^^^^^^^^^^^
+Warning 38: extension constructor Nobody_constructs_me is never used to build values.
+(However, this constructor appears in patterns.)
+module Unused_extension_outside_patterns :
+  sig type t = .. val falsity : t -> bool end
+#             Characters 88-109:
+    exception Private_exn
+    ^^^^^^^^^^^^^^^^^^^^^
+Warning 38: exception Private_exn is never used to build values.
+It is exported or rebound as a private extension.
+module Unused_private_exception : sig type exn += private Private_exn end
+#                 Characters 124-135:
+    type t += Private_ext
+              ^^^^^^^^^^^
+Warning 38: extension constructor Private_ext is never used to build values.
+It is exported or rebound as a private extension.
+module Unused_private_extension :
+  sig type t = .. type t += private Private_ext end
 # 

diff --git a/testsuite/tests/unboxed-primitive-args/common.ml b/testsuite/tests/unboxed-primitive-args/common.ml
index 53ffe7581a4ab82876fea9ac7397af164fe4f88f..d1f13d345e6d3cce9eb4aaff0fba87acae0792cc 100644 (file)
--- a/testsuite/tests/unboxed-primitive-args/common.ml
+++ b/testsuite/tests/unboxed-primitive-args/common.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 open StdLabels
 
 open Bigarray

diff --git a/testsuite/tests/unboxed-primitive-args/common.mli b/testsuite/tests/unboxed-primitive-args/common.mli
index 4f31d84d5e33d18696c207937696144997978295..b7459bb102762aa4e1051510fcfff5cb49a468e1 100644 (file)
--- a/testsuite/tests/unboxed-primitive-args/common.mli
+++ b/testsuite/tests/unboxed-primitive-args/common.mli
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (** Type of arguments/result *)
 type 'a typ =
   | Int       : int       typ

diff --git a/testsuite/tests/unboxed-primitive-args/gen_test.ml b/testsuite/tests/unboxed-primitive-args/gen_test.ml
index 65de0e7b638018fc1544daf785e3b19deb682173..8f4b2dfe59dfba1a78ab42d972931621470edd80 100644 (file)
--- a/testsuite/tests/unboxed-primitive-args/gen_test.ml
+++ b/testsuite/tests/unboxed-primitive-args/gen_test.ml
@@ -1,18 +1,3 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                OCaml                                   *)
-(*                                                                        *)
-(*                  Jeremie Dimino, Jane Street Europe                    *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
 (* This programs generate stubs with various prototype combinations *)
 
 open StdLabels

diff --git a/testsuite/tests/unwind/Makefile b/testsuite/tests/unwind/Makefile
index bd26bc65e8b4cc661b85866f460bfccdfb564fe1..18b39ea357e6f81c35cdad18f6241a7cb4040f16 100644 (file)
--- a/testsuite/tests/unwind/Makefile
+++ b/testsuite/tests/unwind/Makefile
@@ -13,9 +13,11 @@ default:
          LD="`echo $$LDFULL | grep -o \"ld64-[0-9]*\"`"; \
          LDVER="`echo $$LD | sed \"s/ld64-//\"`"; \
          if [[ -z "$$LD" ]]; then \
-           echo " => skipped (ld64-[0-9]* not found in 'ld -v' output)"; \
+           echo " => skipped (unknown linker: pattern ld64-[0-9]* not found" \
+           echo "    in 'ld -v' output)"; \
          elif [[ $$LDVER -lt 224 ]]; then \
-          echo " => skipped (ld version is $$LDVER < 224)"; \
+          echo " => skipped (ld version is $$LDVER, only 224 or above " \
+          echo "    are supported)"; \
          else \
            $(MAKE) native_macosx_tests; \
          fi; \

diff --git a/testsuite/tests/warnings/w01.reference b/testsuite/tests/warnings/w01.reference
index 492ec7dc5226dc817259c664d2c4fe9997ed2de1..5221256f9ce7b0f5410e07f852187713b7e91971 100644 (file)
--- a/testsuite/tests/warnings/w01.reference
+++ b/testsuite/tests/warnings/w01.reference
@@ -5,7 +5,7 @@ Warning 5: this function application is partial,
 maybe some arguments are missing.
 File "w01.ml", line 20, characters 4-5:
 Warning 8: this pattern-matching is not exhaustive.
-Here is an example of a value that is not matched:
+Here is an example of a case that is not matched:
 0
 File "w01.ml", line 25, characters 0-1:
 Warning 10: this expression should have type unit.

diff --git a/testsuite/tests/warnings/w50.ml b/testsuite/tests/warnings/w50.ml
new file mode 100755 (executable)
index 0000000..14877bb
--- /dev/null
+++ b/testsuite/tests/warnings/w50.ml
@@ -0,0 +1,7 @@
+module A : sig end = struct
+  module L = List
+
+  module X1 = struct end
+
+  module Y1 = X1
+end

diff --git a/testsuite/tests/warnings/w50.reference b/testsuite/tests/warnings/w50.reference
new file mode 100644 (file)
index 0000000..db08d0a
--- /dev/null
+++ b/testsuite/tests/warnings/w50.reference
@@ -0,0 +1,4 @@
+File "w50.ml", line 2, characters 2-17:
+Warning 60: unused module L.
+File "w50.ml", line 6, characters 2-16:
+Warning 60: unused module Y1.

diff --git a/testsuite/tests/warnings/w59.opt_backend.clambda.opt_reference b/testsuite/tests/warnings/w59.opt_backend.clambda.opt_reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference b/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
new file mode 100644 (file)
index 0000000..a7e8b93
--- /dev/null
+++ b/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
@@ -0,0 +1,44 @@
+File "w59.opt_backend.ml", line 25, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 26, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 27, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 28, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 25, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 26, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 27, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 28, characters 2-43:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.
+File "w59.opt_backend.ml", line 35, characters 2-7:
+Warning 59: A potential assignment to a non-mutable value was detected 
+in this source file.  Such assignments may generate incorrect code 
+when using Flambda.

diff --git a/testsuite/tests/warnings/w59.opt_backend.ml b/testsuite/tests/warnings/w59.opt_backend.ml
new file mode 100644 (file)
index 0000000..91e5147
--- /dev/null
+++ b/testsuite/tests/warnings/w59.opt_backend.ml
@@ -0,0 +1,44 @@
+
+(* Check that the warning 59 (assignment to immutable value) does not
+   trigger on those examples *)
+let a = Lazy.force (lazy "a")
+let b = Lazy.force (lazy 1)
+let c = Lazy.force (lazy 3.14)
+let d = Lazy.force (lazy 'a')
+let e = Lazy.force (lazy (fun x -> x+1))
+let rec f (x:int) : int = g x and g x = f x
+let h = Lazy.force (lazy f)
+let i = Lazy.force (lazy g)
+let j = Lazy.force (lazy 1L)
+let k = Lazy.force (lazy (1,2))
+let l = Lazy.force (lazy [|3.14|])
+let m = Lazy.force (lazy (Sys.opaque_identity 3.14))
+let n = Lazy.force (lazy None)
+
+(* Check that obviously wrong code is reported *)
+let o = (1,2)
+let p = fun x -> x
+let q = 3.14
+let r = 1
+
+let () =
+  Obj.set_field (Obj.repr o) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr p) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr q) 0 (Obj.repr 3);
+  Obj.set_field (Obj.repr r) 0 (Obj.repr 3)
+
+let set v =
+  Obj.set_field (Obj.repr v) 0 (Obj.repr 3)
+  [@@inline]
+
+let () =
+  set o
+
+(* Sys.opaque_identity hide all information and shouldn't warn *)
+
+let opaque = Sys.opaque_identity (1,2)
+let set_opaque =
+  Obj.set_field
+    (Obj.repr opaque)
+    0
+    (Obj.repr 3)

diff --git a/testsuite/tests/warnings/w59.opt_backend.reference b/testsuite/tests/warnings/w59.opt_backend.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tools/Makefile b/testsuite/tools/Makefile
new file mode 100644 (file)
index 0000000..8c9dd05
--- /dev/null
+++ b/testsuite/tools/Makefile
@@ -0,0 +1,31 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Jeremie Dimino, Jane Street Europe                     *
+#*                                                                        *
+#*   Copyright 2016 Jane Street Group LLC                                 *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=..
+MAIN=expect_test
+PROG=$(MAIN)$(EXE)
+COMPFLAGS=-I $(OTOPDIR)/parsing -I $(OTOPDIR)/utils \
+          -I $(OTOPDIR)/driver -I $(OTOPDIR)/toplevel
+LIBRARIES=../../compilerlibs/ocamlcommon \
+          ../../compilerlibs/ocamlbytecomp \
+          ../../compilerlibs/ocamltoplevel
+
+$(PROG): $(MAIN).cmo
+       $(OCAMLC) -linkall -o $(PROG) $(LIBRARIES:=.cma) $(MAIN).cmo
+
+include $(BASEDIR)/makefiles/Makefile.common
+
+.PHONY: clean
+clean: defaultclean
+       rm -f $(PROG)

diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml
new file mode 100644 (file)
index 0000000..6ddd44b
--- /dev/null
+++ b/testsuite/tools/expect_test.ml
@@ -0,0 +1,366 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2016 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Execute a list of phrases from a .ml file and compare the result to the
+   expected output, written inside [%%expect ...] nodes. At the end, create
+   a .corrected file containing the corrected expectations. The test is
+   successful if there is no differences between the two files.
+
+   An [%%expect] node always contains both the expected outcome with and
+   without -principal. When the two differ the expectation is written as
+   follows:
+
+   {[
+     [%%expect {|
+     output without -principal
+     |}, Principal{|
+     output with -principal
+     |}]
+   ]}
+*)
+
+[@@@ocaml.warning "-40"]
+
+open StdLabels
+
+(* representation of: {tag|str|tag} *)
+type string_constant =
+  { str : string
+  ; tag : string
+  }
+
+type expectation =
+  { extid_loc   : Location.t (* Location of "expect" in "[%%expect ...]" *)
+  ; payload_loc : Location.t (* Location of the whole payload *)
+  ; normal      : string_constant (* expectation without -principal *)
+  ; principal   : string_constant (* expectation with -principal *)
+  }
+
+(* A list of phrases with the expected toplevel output *)
+type chunk =
+  { phrases     : Parsetree.toplevel_phrase list
+  ; expectation : expectation
+  }
+
+type correction =
+  { corrected_expectations : expectation list
+  ; trailing_output        : string
+  }
+
+let match_expect_extension (ext : Parsetree.extension) =
+  match ext with
+  | ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) ->
+    let invalid_payload () =
+      Location.raise_errorf ~loc:extid_loc
+        "invalid [%%%%expect payload]"
+    in
+    let string_constant (e : Parsetree.expression) =
+      match e.pexp_desc with
+      | Pexp_constant (Pconst_string (str, Some tag)) ->
+        { str; tag }
+      | _ -> invalid_payload ()
+    in
+    let expectation =
+      match payload with
+      | PStr [{ pstr_desc = Pstr_eval (e, []) }] ->
+        let normal, principal =
+          match e.pexp_desc with
+          | Pexp_tuple
+              [ a
+              ; { pexp_desc = Pexp_construct
+                                ({ txt = Lident "Principal"; _ }, Some b) }
+              ] ->
+            (string_constant a, string_constant b)
+          | _ -> let s = string_constant e in (s, s)
+        in
+        { extid_loc
+        ; payload_loc = e.pexp_loc
+        ; normal
+        ; principal
+        }
+      | PStr [] ->
+        let s = { tag = ""; str = "" } in
+        { extid_loc
+        ; payload_loc  = { extid_loc with loc_start = extid_loc.loc_end }
+        ; normal    = s
+        ; principal = s
+        }
+      | _ -> invalid_payload ()
+    in
+    Some expectation
+  | _ ->
+    None
+
+(* Split a list of phrases from a .ml file *)
+let split_chunks phrases =
+  let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc =
+    match phrases with
+    | [] ->
+      if code_acc = [] then
+        (List.rev acc, None)
+      else
+        (List.rev acc, Some (List.rev code_acc))
+    | phrase :: phrases ->
+      match phrase with
+      | Ptop_def [] -> loop phrases code_acc acc
+      | Ptop_def [{pstr_desc = Pstr_extension(ext, [])}] -> begin
+          match match_expect_extension ext with
+          | None -> loop phrases (phrase :: code_acc) acc
+          | Some expectation ->
+            let chunk =
+              { phrases     = List.rev code_acc
+              ; expectation
+              }
+            in
+            loop phrases [] (chunk :: acc)
+        end
+      | _ -> loop phrases (phrase :: code_acc) acc
+  in
+  loop phrases [] []
+
+module Compiler_messages = struct
+  let print_loc ppf (loc : Location.t) =
+    let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
+    let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
+    Format.fprintf ppf "Line _";
+    if startchar >= 0 then
+      Format.fprintf ppf ", characters %d-%d" startchar endchar;
+    Format.fprintf ppf ":@."
+
+  let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error)=
+    print_loc ppf loc;
+    Format.fprintf ppf "%a %s" Location.print_error_prefix () msg;
+    List.iter sub ~f:(fun err ->
+      Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err)
+
+  let warning_printer loc ppf w =
+    if Warnings.is_active w then begin
+      print_loc ppf loc;
+      Format.fprintf ppf "Warning %a@." Warnings.print w
+    end
+
+  let capture ppf ~f =
+    Misc.protect_refs
+      [ R (Location.formatter_for_warnings , ppf            )
+      ; R (Location.warning_printer        , warning_printer)
+      ; R (Location.error_reporter         , error_reporter )
+      ]
+      f
+end
+
+let collect_formatters buf pps ~f =
+  List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
+  let save =
+    List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps
+  in
+  let restore () =
+    List.iter2
+      (fun pp out_functions ->
+         Format.pp_print_flush pp ();
+         Format.pp_set_formatter_out_functions pp out_functions)
+      pps save
+  in
+  let out_string str ofs len = Buffer.add_substring buf str ofs len
+  and out_flush = ignore
+  and out_newline () = Buffer.add_char buf '\n'
+  and out_spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
+  let out_functions =
+    { Format.out_string; out_flush; out_newline; out_spaces }
+  in
+  List.iter
+    (fun pp -> Format.pp_set_formatter_out_functions pp out_functions)
+    pps;
+  match f () with
+  | x             -> restore (); x
+  | exception exn -> restore (); raise exn
+
+(* Invariant: ppf = Format.formatter_of_buffer buf *)
+let capture_everything buf ppf ~f =
+  collect_formatters buf [Format.std_formatter; Format.err_formatter]
+                     ~f:(fun () -> Compiler_messages.capture ppf ~f)
+
+let exec_phrase ppf phrase =
+  if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase;
+  if !Clflags.dump_source    then Pprintast.top_phrase ppf phrase;
+  Toploop.execute_phrase true ppf phrase
+
+let parse_contents ~fname contents =
+  let lexbuf = Lexing.from_string contents in
+  Location.init lexbuf fname;
+  Location.input_name := fname;
+  Parse.use_file lexbuf
+
+let eval_expectation expectation ~output =
+  let s =
+    if !Clflags.principal then
+      expectation.principal
+    else
+      expectation.normal
+  in
+  if s.str = output then
+    None
+  else
+    let s = { s with str = output } in
+    Some (
+      if !Clflags.principal then
+        { expectation with principal = s }
+      else
+        { expectation with normal = s }
+    )
+
+let shift_lines delta phrases =
+  let position (pos : Lexing.position) =
+    { pos with pos_lnum = pos.pos_lnum + delta }
+  in
+  let location _this (loc : Location.t) =
+    { loc with
+      loc_start = position loc.loc_start
+    ; loc_end   = position loc.loc_end
+    }
+  in
+  let mapper = { Ast_mapper.default_mapper with location } in
+  List.map phrases ~f:(function
+    | Parsetree.Ptop_dir _ as p -> p
+    | Parsetree.Ptop_def st ->
+      Parsetree.Ptop_def (mapper.structure mapper st))
+
+let rec min_line_number : Parsetree.toplevel_phrase list -> int option =
+function
+  | [] -> None
+  | (Ptop_dir _  | Ptop_def []) :: l -> min_line_number l
+  | Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum
+
+let eval_expect_file _fname ~file_contents =
+  Warnings.reset_fatal ();
+  let chunks, trailing_code =
+    parse_contents ~fname:"" file_contents |> split_chunks
+  in
+  let buf = Buffer.create 1024 in
+  let ppf = Format.formatter_of_buffer buf in
+  let exec_phrases phrases =
+    let phrases =
+      match min_line_number phrases with
+      | None -> phrases
+      | Some lnum -> shift_lines (1 - lnum) phrases
+    in
+    (* For formatting purposes *)
+    Buffer.add_char buf '\n';
+    let _ : bool =
+      List.fold_left phrases ~init:true ~f:(fun acc phrase ->
+        acc &&
+        try
+          exec_phrase ppf phrase
+        with exn ->
+          Location.report_exception ppf exn;
+          false)
+    in
+    Format.pp_print_flush ppf ();
+    let len = Buffer.length buf in
+    if len > 0 && Buffer.nth buf (len - 1) <> '\n' then
+      (* For formatting purposes *)
+      Buffer.add_char buf '\n';
+    let s = Buffer.contents buf in
+    Buffer.clear buf;
+    Misc.delete_eol_spaces s
+  in
+  let corrected_expectations =
+    capture_everything buf ppf ~f:(fun () ->
+      List.fold_left chunks ~init:[] ~f:(fun acc chunk ->
+        let output = exec_phrases chunk.phrases in
+        match eval_expectation chunk.expectation ~output with
+        | None -> acc
+        | Some correction -> correction :: acc)
+      |> List.rev)
+  in
+  let trailing_output =
+    match trailing_code with
+    | None -> ""
+    | Some phrases ->
+      capture_everything buf ppf ~f:(fun () -> exec_phrases phrases)
+  in
+  { corrected_expectations; trailing_output }
+
+let output_slice oc s a b =
+  output_string oc (String.sub s ~pos:a ~len:(b - a))
+
+let output_corrected oc ~file_contents correction =
+  let output_body oc { str; tag } =
+    Printf.fprintf oc "{%s|%s|%s}" tag str tag
+  in
+  let ofs =
+    List.fold_left correction.corrected_expectations ~init:0
+      ~f:(fun ofs c ->
+        output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum;
+        output_body oc c.normal;
+        if c.normal.str <> c.principal.str then begin
+          output_string oc ", Principal";
+          output_body oc c.principal
+        end;
+        c.payload_loc.loc_end.pos_cnum)
+  in
+  output_slice oc file_contents ofs (String.length file_contents);
+  match correction.trailing_output with
+  | "" -> ()
+  | s  -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s
+
+let write_corrected ~file ~file_contents correction =
+  let oc = open_out file in
+  output_corrected oc ~file_contents correction;
+  close_out oc
+
+let process_expect_file fname =
+  let corrected_fname = fname ^ ".corrected" in
+  let file_contents =
+    let ic = open_in_bin fname in
+    match really_input_string ic (in_channel_length ic) with
+    | s           -> close_in ic; Misc.normalise_eol s
+    | exception e -> close_in ic; raise e
+  in
+  let correction = eval_expect_file fname ~file_contents in
+  write_corrected ~file:corrected_fname ~file_contents correction
+
+let repo_root = ref ""
+
+let main fname =
+  Toploop.override_sys_argv
+    (Array.sub Sys.argv ~pos:!Arg.current
+       ~len:(Array.length Sys.argv - !Arg.current));
+  (* Ignore OCAMLRUNPARAM=b to be reproducible *)
+  Printexc.record_backtrace false;
+  List.iter [ "stdlib" ] ~f:(fun s ->
+    Topdirs.dir_directory (Filename.concat !repo_root s));
+  Toploop.initialize_toplevel_env ();
+  Sys.interactive := false;
+  process_expect_file fname;
+  exit 0
+
+let args =
+  Arg.align
+    [ "-repo-root", Set_string repo_root,
+      "<dir> root of the OCaml repository"
+    ; "-principal", Set Clflags.principal,
+      " Evaluate the file with -principal set"
+    ]
+
+let usage = "Usage: expect_test <options> [script-file [arguments]]\n\
+             options are:"
+
+let () =
+  try
+    Arg.parse args main usage;
+    Printf.eprintf "expect_test: no input file\n";
+    exit 2
+  with exn ->
+    Location.report_exception Format.err_formatter exn;
+    exit 2

diff --git a/tools/.depend b/tools/.depend
index 7ef2e505374ab8cce49f6f13eb2abadf3a3f5fce..b578b0ec4d67dce3c6d2f2e1cfc4cb52520de488 100644 (file)
--- a/tools/.depend
+++ b/tools/.depend
@@ -1,5 +1,3 @@
-depend.cmi : ../parsing/parsetree.cmi ../parsing/longident.cmi
-profiling.cmi :
 addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \
     ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi
 addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \
@@ -20,12 +18,6 @@ cmt2annot.cmx : ../typing/untypeast.cmx ../typing/types.cmx \
     ../parsing/asttypes.cmi ../typing/annot.cmi
 cvt_emit.cmo :
 cvt_emit.cmx :
-depend.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \
-    ../parsing/longident.cmi ../parsing/location.cmi ../utils/clflags.cmi \
-    ../parsing/builtin_attributes.cmi ../parsing/asttypes.cmi depend.cmi
-depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \
-    ../parsing/longident.cmx ../parsing/location.cmx ../utils/clflags.cmx \
-    ../parsing/builtin_attributes.cmx ../parsing/asttypes.cmi depend.cmi
 dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
     ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \
     ../typing/ident.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \
@@ -57,11 +49,13 @@ ocamlcp.cmx : ../driver/main_args.cmx
 ocamldep.cmo : ../driver/pparse.cmi ../parsing/parsetree.cmi \
     ../parsing/parser.cmi ../parsing/parse.cmi ../utils/misc.cmi \
     ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
-    depend.cmi ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi
+    ../parsing/depend.cmi ../utils/config.cmi ../driver/compenv.cmi \
+    ../utils/clflags.cmi
 ocamldep.cmx : ../driver/pparse.cmx ../parsing/parsetree.cmi \
     ../parsing/parser.cmx ../parsing/parse.cmx ../utils/misc.cmx \
     ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
-    depend.cmx ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx
+    ../parsing/depend.cmx ../utils/config.cmx ../driver/compenv.cmx \
+    ../utils/clflags.cmx
 ocamlmklib.cmo : ocamlmklibconfig.cmo ../utils/config.cmi
 ocamlmklib.cmx : ocamlmklibconfig.cmx ../utils/config.cmx
 ocamlmklibconfig.cmo :
@@ -80,6 +74,7 @@ primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi
 primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
 profiling.cmo : profiling.cmi
 profiling.cmx : profiling.cmi
+profiling.cmi :
 read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi
 read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx
 scrapelabels.cmo :

diff --git a/tools/Makefile b/tools/Makefile
index 0e91277ce7f75d30508b7b01931bb8bb50b1781c..7ab2f11f7334d1ca894257ecd73eed2ba0ba8f95 100644 (file)
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -14,15 +14,3 @@
 #**************************************************************************
 
 include Makefile.shared
-
-# To make custom toplevels
-
-ocamlmktop: ocamlmktop.tpl ../config/Makefile
-       sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop
-       chmod +x ocamlmktop
-
-install::
-       cp ocamlmktop "$(INSTALL_BINDIR)"
-
-clean::
-       rm -f ocamlmktop

diff --git a/tools/Makefile.nt b/tools/Makefile.nt
index 3a16f967f7c313c4e969b129768db8cfa22cc57f..8ebcf29e7996ad91bb2d444569eb1e4dead369f4 100644 (file)
--- a/tools/Makefile.nt
+++ b/tools/Makefile.nt
@@ -16,20 +16,9 @@
 include Makefile.shared
 
 ifneq "$(wildcard ../flexdll/Makefile)" ""
-  CAMLOPT:=OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe" $(CAMLOPT)
+CAMLOPT := OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe" \
+  $(CAMLOPT)
 endif
 
-# To make custom toplevels
-
-OCAMLMKTOP=ocamlmktop.cmo
-OCAMLMKTOP_IMPORTS=misc.cmo identifiable.cmo numbers.cmo config.cmo \
-                  arg_helper.cmo clflags.cmo ccomp.cmo
-
-ocamlmktop: $(OCAMLMKTOP)
-       $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP)
-
-install::
-       cp ocamlmktop "$(INSTALL_BINDIR)/ocamlmktop$(EXE)"
-
 clean::
-       rm -f ocamlmktop objinfo_helper$(EXE).manifest
+       rm -f "objinfo_helper$(EXE).manifest"

diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index 1a24391f029f954da563e29102093176df121cb2..2803d7860c905623f73a9d2459620ab63a99cd6e 100644 (file)
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -12,48 +12,107 @@
 #*   special exception on linking described in the file LICENSE.          *
 #*                                                                        *
 #**************************************************************************
-
+MAKEFLAGS := -r -R
 include ../config/Makefile
+INSTALL_BINDIR:=$(DESTDIR)$(BINDIR)
+INSTALL_LIBDIR:=$(DESTDIR)$(LIBDIR)
+INSTALL_COMPLIBDIR:=$(DESTDIR)$(COMPLIBDIR)
+INSTALL_STUBLIBDIR:=$(DESTDIR)$(STUBLIBDIR)
+INSTALL_MANDIR:=$(DESTDIR)$(MANDIR)
+
+ifeq ($(SYSTEM),unix)
+override define shellquote
+$i := $$(subst ",\",$$(subst $$$$,\$$$$,$$(subst `,\`,$i)))#")#
+endef
+$(foreach i,BINDIR LIBDIR COMPLIBDIR STUBLIBDIR MANDIR,$(eval $(shellquote)))
+endif
+
 CAMLRUN ?= ../boot/ocamlrun
 CAMLYACC ?= ../boot/ocamlyacc
+DESTDIR ?=
+# Setup GNU make variables storing per-target source and target,
+# a list of installed tools, and a function to quote a filename for
+# the shell.
+override installed_tools := ocamldep ocamlprof ocamlcp ocamloptp \
+                   ocamlmktop ocamlmklib ocamlobjinfo
+
+install_files :=
+define byte2native
+$(patsubst %.cmo,%.cmx,$(patsubst %.cma,%.cmxa,$1))
+endef
+
+# $1 = target, $2 = OCaml object dependencies, $3 = other dependencies
+# There is a lot of subtle code here.  The multiple layers of expansion
+# are due to `make`'s eval() function, which evaluates the string
+# passed to it as a makefile fragment.  So it is crucial that variables
+# not get expanded too many times.
+define byte_and_opt_
+# This check is defensive programming
+$(and $(filter-out 1,$(words $1)),$(error \
+   cannot build file with whitespace in name))
+$1: $3 $2
+       $$(CAMLC) $$(LINKFLAGS) -I .. -o $$@ $2
+
+$1.opt: $3 $$(call byte2native,$2)
+       $$(CAMLOPT) $$(LINKFLAGS) -I .. -o $$@ $$(call byte2native,$2)
+
+all: $1
+
+opt.opt: $1.opt
+
+ifeq '$(filter $(installed_tools),$1)' '$1'
+install_files += $1
+endif
+clean::
+       rm -f -- $1 $1.opt
+
+endef
 
-CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot
+# Escape any $ characters in the arguments and eval the result.
+define byte_and_opt
+$(eval $(call \
+ byte_and_opt_,$(subst $$,$$$$,$1),$(subst $$,$$$$,$2),$(subst $$,$$$$,$3)))
+endef
+
+ROOTDIR=..
+
+ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" ""
+export OCAML_FLEXLINK:=
+else
+export OCAML_FLEXLINK:=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/flexdll/flexlink.exe
+endif
+
+CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot \
+      -use-prims ../byterun/primitives -I ..
 CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib
 CAMLLEX=$(CAMLRUN) ../boot/ocamllex
 INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
          -I ../middle_end -I ../middle_end/base_types -I ../driver \
          -I ../toplevel
-COMPFLAGS= -strict-sequence -w +27+32..39 -warn-error A -safe-string $(INCLUDES)
+COMPFLAGS= -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \
+ -safe-string -strict-formats $(INCLUDES)
 LINKFLAGS=$(INCLUDES)
-
-all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \
-     objinfo read_cmt stripdebug cmpbyt
+VPATH := $(filter-out -I,$(INCLUDES))
 
 # scrapelabels addlabels
 
-.PHONY: all
-
-opt.opt: ocamldep.opt read_cmt.opt
-.PHONY: opt.opt
+.PHONY: all opt.opt
 
 # The dependency generator
 
-CAMLDEP_OBJ=depend.cmo ocamldep.cmo
+CAMLDEP_OBJ=ocamldep.cmo
 CAMLDEP_IMPORTS=timings.cmo misc.cmo config.cmo identifiable.cmo numbers.cmo \
   arg_helper.cmo clflags.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
   syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \
   ccomp.cmo ast_mapper.cmo ast_iterator.cmo \
   builtin_attributes.cmo ast_invariants.cmo \
-  pparse.cmo compenv.cmo
-
-ocamldep: depend.cmi $(CAMLDEP_OBJ)
-       $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) \
-                $(CAMLDEP_OBJ)
+  pparse.cmo compenv.cmo depend.cmo
 
-ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx)
-       $(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \
-                  $(CAMLDEP_OBJ:.cmo=.cmx)
+ocamldep: LINKFLAGS += -compat-32
+$(call byte_and_opt,ocamldep,$(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ),)
+ocamldep: depend.cmi
+ocamldep.opt: depend.cmi
 
 # ocamldep is precious: sometimes we are stuck in the middle of a
 # bootstrap and we need to remake the dependencies
@@ -62,14 +121,6 @@ clean::
        rm -f ocamldep.opt
 
 
-INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
-
-install::
-       cp ocamldep "$(INSTALL_BINDIR)/ocamldep$(EXE)"
-       if test -f ocamldep.opt; then \
-         cp ocamldep.opt "$(INSTALL_BINDIR)/ocamldep.opt$(EXE)"; else :; fi
-
 # The profiler
 
 CSLPROF=ocamlprof.cmo
@@ -78,46 +129,27 @@ CSLPROF_IMPORTS=misc.cmo config.cmo identifiable.cmo numbers.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
   syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo
 
-ocamlprof: $(CSLPROF) profiling.cmo
-       $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF)
+$(call byte_and_opt,ocamlprof,$(CSLPROF_IMPORTS) profiling.cmo $(CSLPROF),)
 
-ocamlcp: ocamlcp.cmo
-       $(CAMLC) $(LINKFLAGS) -o ocamlcp misc.cmo warnings.cmo config.cmo \
-                 identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo \
-                main_args.cmo ocamlcp.cmo
+ocamlcp_cmos = misc.cmo warnings.cmo config.cmo identifiable.cmo numbers.cmo \
+              arg_helper.cmo clflags.cmo main_args.cmo
 
-ocamloptp: ocamloptp.cmo
-       $(CAMLC) $(LINKFLAGS) -o ocamloptp misc.cmo warnings.cmo config.cmo \
-                 identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo \
-                main_args.cmo \
-                ocamloptp.cmo
+$(call byte_and_opt,ocamlcp,$(ocamlcp_cmos) ocamlcp.cmo,)
+$(call byte_and_opt,ocamloptp,$(ocamlcp_cmos) ocamloptp.cmo,)
 
 opt:: profiling.cmx
 
 install::
-       cp ocamlprof "$(INSTALL_BINDIR)/ocamlprof$(EXE)"
-       cp ocamlcp "$(INSTALL_BINDIR)/ocamlcp$(EXE)"
-       cp ocamloptp "$(INSTALL_BINDIR)/ocamloptp$(EXE)"
-       cp profiling.cmi profiling.cmo "$(INSTALL_LIBDIR)"
+       cp -- profiling.cmi profiling.cmo "$(INSTALL_LIBDIR)"
 
 installopt::
-       cp profiling.cmx profiling.$(O) "$(INSTALL_LIBDIR)"
-
-clean::
-       rm -f ocamlprof ocamlcp ocamloptp
-
+       cp -- profiling.cmx profiling.$(O) "$(INSTALL_LIBDIR)"
 
 # To help building mixed-mode libraries (OCaml + C)
 
-ocamlmklib: ocamlmklibconfig.cmo ocamlmklib.cmo
-       $(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklibconfig.cmo config.cmo \
-                ocamlmklib.cmo
-
-install::
-       cp ocamlmklib "$(INSTALL_BINDIR)/ocamlmklib$(EXE)"
+$(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo \
+                ocamlmklib.cmo,)
 
-clean::
-       rm -f ocamlmklib
 
 ocamlmklibconfig.ml: ../config/Makefile Makefile
        (echo 'let bindir = "$(BINDIR)"'; \
@@ -134,6 +166,14 @@ beforedepend:: ocamlmklibconfig.ml
 clean::
        rm -f ocamlmklibconfig.ml
 
+# To make custom toplevels
+
+OCAMLMKTOP=ocamlmktop.cmo
+OCAMLMKTOP_IMPORTS=misc.cmo identifiable.cmo numbers.cmo config.cmo \
+                  arg_helper.cmo clflags.cmo ccomp.cmo
+
+$(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),)
+
 # Converter olabl/ocaml 2.99 to ocaml 3
 
 OCAML299TO3= lexer299.cmo ocaml299to3.cmo
@@ -181,6 +221,24 @@ addlabels: addlabels.cmo
 #install::
 #      cp addlabels "$(INSTALL_LIBDIR)"
 
+ifeq ($(UNIX_OR_WIN32),unix)
+LN := ln -sf
+else
+LN := cp -pf
+endif
+
+install::
+       for i in $(install_files); \
+       do \
+         cp -- "$$i" "$(INSTALL_BINDIR)/$$i.byte$(EXE)" && \
+         if test -f "$$i".opt; then \
+           cp -- "$$i.opt" "$(INSTALL_BINDIR)/$$i.opt$(EXE)" && \
+           (cd "$(INSTALL_BINDIR)/" && $(LN) "$$i.opt$(EXE)" "$$i$(EXE)"); \
+         else \
+           (cd "$(INSTALL_BINDIR)/" && $(LN) "$$i.byte$(EXE)" "$$i$(EXE)"); \
+         fi; \
+       done
+
 clean::
        rm -f addlabels
 
@@ -193,6 +251,7 @@ cvt_emit: $(CVT_EMIT)
 
 # cvt_emit is precious: sometimes we are stuck in the middle of a
 # bootstrap and we need to remake the dependencies
+.PRECIOUS: cvt_emit
 clean::
        if test -f cvt_emit; then mv -f cvt_emit cvt_emit.bak; else :; fi
 
@@ -204,7 +263,6 @@ clean::
 
 beforedepend:: cvt_emit.ml
 
-
 # Reading cmt files
 
 READ_CMT= \
@@ -213,32 +271,17 @@ READ_CMT= \
           \
           cmt2annot.cmo read_cmt.cmo
 
-READ_CMT_OPT1 = $(READ_CMT:.cmo=.cmx)
-READ_CMT_OPT = $(READ_CMT_OPT1:.cma=.cmxa)
-
-read_cmt: $(READ_CMT)
-       $(CAMLC) $(LINKFLAGS) -o read_cmt $(READ_CMT)
-
-read_cmt.opt: $(READ_CMT_OPT)
-       $(CAMLOPT) $(LINKFLAGS) -o read_cmt.opt $(READ_CMT_OPT)
-
-clean::
-       rm -f read_cmt read_cmt.opt
+# Reading cmt files
+$(call byte_and_opt,read_cmt,$(READ_CMT),)
 
-beforedepend::
 
 # The bytecode disassembler
 
 DUMPOBJ=opnames.cmo dumpobj.cmo
 
-dumpobj: $(DUMPOBJ)
-       $(CAMLC) $(LINKFLAGS) -o dumpobj \
-                misc.cmo identifiable.cmo numbers.cmo \
-                 tbl.cmo config.cmo ident.cmo \
-                opcodes.cmo bytesections.cmo $(DUMPOBJ)
-
-clean::
-       rm -f dumpobj
+$(call byte_and_opt,dumpobj,misc.cmo identifiable.cmo numbers.cmo tbl.cmo \
+                    config.cmo ident.cmo opcodes.cmo bytesections.cmo \
+                   $(DUMPOBJ),)
 
 opnames.ml: ../byterun/caml/instruct.h
        unset LC_ALL || : ; \
@@ -283,37 +326,25 @@ OBJINFO=../compilerlibs/ocamlcommon.cma \
         ../asmcomp/export_info.cmo \
         objinfo.cmo
 
-objinfo: objinfo_helper$(EXE) $(OBJINFO)
-       $(CAMLC) -o objinfo $(OBJINFO)
+$(call byte_and_opt,ocamlobjinfo,$(OBJINFO),objinfo_helper$(EXE))
 
 install::
-       cp objinfo "$(INSTALL_BINDIR)/ocamlobjinfo$(EXE)"
        cp objinfo_helper$(EXE) "$(INSTALL_LIBDIR)/objinfo_helper$(EXE)"
 
-clean::
-       rm -f objinfo objinfo_helper$(EXE)
-
 # Scan object files for required primitives
-
-PRIMREQ=primreq.cmo
-
-primreq: $(PRIMREQ)
-       $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ)
+$(call byte_and_opt,primreq,config.cmo primreq.cmo,)
 
 clean::
-       rm -f primreq
+       rm -f "objinfo_helper$(EXE)"
+
 
 # Copy a bytecode executable, stripping debug info
 
-STRIPDEBUG=../compilerlibs/ocamlcommon.cma \
+stripdebug=../compilerlibs/ocamlcommon.cma \
            ../compilerlibs/ocamlbytecomp.cma \
            stripdebug.cmo
 
-stripdebug: $(STRIPDEBUG)
-       $(CAMLC) $(LINKFLAGS) -o stripdebug $(STRIPDEBUG)
-
-clean::
-       rm -f stripdebug
+$(call byte_and_opt,stripdebug,$(stripdebug),)
 
 # Compare two bytecode executables
 
@@ -321,36 +352,31 @@ CMPBYT=../compilerlibs/ocamlcommon.cma \
        ../compilerlibs/ocamlbytecomp.cma \
        cmpbyt.cmo
 
-cmpbyt: $(CMPBYT)
-       $(CAMLC) $(LINKFLAGS) -o cmpbyt $(CMPBYT)
-
-clean::
-       rm -f cmpbyt
+$(call byte_and_opt,cmpbyt,$(CMPBYT),)
 
 ifeq "$(RUNTIMEI)" "true"
 install::
-       cp ocaml-instr-graph ocaml-instr-report $(INSTALL_BINDIR)/
+       cp ocaml-instr-graph ocaml-instr-report "$(INSTALL_BINDIR)/"
 endif
 
 # Common stuff
 
 .SUFFIXES:
-.SUFFIXES: .ml .cmo .mli .cmi .cmx
 
-.ml.cmo:
-       $(CAMLC) -c $(COMPFLAGS) $<
+%.cmo: %.ml
+       $(CAMLC) -c $(COMPFLAGS) - $<
 
-.mli.cmi:
-       $(CAMLC) -c $(COMPFLAGS) $<
+%.cmi: %.mli
+       $(CAMLC) -c $(COMPFLAGS) - $<
 
-.ml.cmx:
-       $(CAMLOPT) $(COMPFLAGS) -c $<
+%.cmx: %.ml
+       $(CAMLOPT) $(COMPFLAGS) -c - $<
 
 clean::
        rm -f *.cmo *.cmi *.cma *.dll *.so *.lib *.a
 
 depend: beforedepend
-       $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend
+       $(CAMLRUN) ./ocamldep -slash $(INCLUDES) *.mli *.ml > .depend
 
 .PHONY: clean install beforedepend depend
 

diff --git a/tools/check-typo b/tools/check-typo
index 9b6c7c6fa4831d3ae691fad0d4a5fd85b5aa2eae..a19943a6c0a1e2226b211b6d431a46b25a128efb 100755 (executable)
--- a/tools/check-typo
+++ b/tools/check-typo
@@ -237,6 +237,7 @@ IGNORE_DIRS="
         state == "close" && $0 ~ /\*{74}/ { state = "OK"; }
         state == "close" { state = "(last line)"; }
         state == "blurb" && $0 ~ /\* {72}\*/ { state = "close"; }
+        state == "blurb" && $0 ~ /\/LICENSE/ { state = "(license path)" }
         state == "blurb1" && $0 ~ /\*   All rights reserved. .{47} \*/ \
                                                  { state = "blurb"; }
         state == "blurb1" { state = "(blurb line 1)"; }

diff --git a/tools/ci-build b/tools/ci-build
index 6d9439e35b0bffe14c61850b20d1d16b3a990c3e..8e0969cdc52a7d69be9f3bcde955a00862d57a32 100755 (executable)
--- a/tools/ci-build
+++ b/tools/ci-build
@@ -23,8 +23,9 @@
 #    for windows, this is relative to $HOME/jenkins-workspace
 #    for bsd, macos, linux, this is ignored and the build is always in .
 # 3. options:
-#    -conf configure-option
+#    -conf configure-option  add configure-option to configure cmd line
 #    -patch1 file-name       apply patch with -p1
+#    -newmakefiles           do not use Makefile.nt even for Windows
 
 error () {
   echo "$1" >&2
@@ -81,7 +82,8 @@ set -ex
 make=make
 instdir="$HOME/ocaml-tmp-install"
 docheckout=false
-nt=
+makefile=Makefile
+configure=unix
 
 case "$arch" in
   bsd)
@@ -102,25 +104,29 @@ case "$arch" in
     instdir=/cygdrive/c/ocamlmgw
     workdir="$HOME/jenkins-workspace/$branch"
     docheckout=true
-    nt=.nt
+    makefile=Makefile.nt
+    configure=nt
   ;;
   mingw64)
     instdir=/cygdrive/c/ocamlmgw64
     workdir="$HOME/jenkins-workspace/$branch"
     docheckout=true
-    nt=.nt
+    makefile=Makefile.nt
+    configure=nt
   ;;
   msvc)
     instdir=/cygdrive/c/ocamlms
     workdir="$HOME/jenkins-workspace/$branch"
     docheckout=true
-    nt=.nt
+    makefile=Makefile.nt
+    configure=nt
   ;;
   msvc64)
     instdir=/cygdrive/c/ocamlms64
     workdir="$HOME/jenkins-workspace/$branch"
     docheckout=true
-    nt=.nt
+    makefile=Makefile.nt
+    configure=nt
   ;;
   *) error "unknown architecture: $arch";;
 esac
@@ -138,10 +144,12 @@ cd "$workdir"
 confoptions=""
 while [ $# -gt 0 ]; do
   case $1 in
-    -conf) confoptions="$confoptions `quote1 "$2"`"; shift 2;;
-    -patch1) patch -f -p1 <"$2"; shift 2;;
+    -conf) confoptions="$confoptions `quote1 "$2"`"; shift;;
+    -patch1) patch -f -p1 <"$2"; shift;;
+    -newmakefiles) makefile=Makefile;;
     *) error "unknown option $1";;
   esac
+  shift
 done
 
 #########################################################################
@@ -150,15 +158,15 @@ done
 # Tell gcc to use only ASCII in its diagnostic outputs.
 export LC_ALL=C
 
-$make -f Makefile$nt distclean || :
+$make -f $makefile distclean || :
 
 if $docheckout; then
   git pull
 fi
 
-case $nt in
-  "") eval "./configure -prefix '$instdir' $confoptions";;
-  .nt)
+case $configure in
+  unix) eval "./configure -prefix '$instdir' $confoptions";;
+  nt)
     cp config/m-nt.h config/m.h
     cp config/s-nt.h config/s.h
     cp config/Makefile.$arch config/Makefile
@@ -166,8 +174,8 @@ case $nt in
   *) error "internal error";;
 esac
 
-$make -f Makefile$nt world.opt
-$make -f Makefile$nt install
+$make -f $makefile world.opt
+$make -f $makefile install
 
 rm -rf "$instdir"
 cd testsuite

diff --git a/tools/cmpbyt.ml b/tools/cmpbyt.ml
index e6b42434b82416e35ce418017ab102ad0366e491..983234fe312f187c2248d80b131bdf601e7d8cf2 100644 (file)
--- a/tools/cmpbyt.ml
+++ b/tools/cmpbyt.ml
@@ -84,4 +84,4 @@ let _ =
     eprintf "Usage: cmpbyt <file 1> <file 2>\n";
     exit 2
   end;
-  if cmpbyt Sys.argv.(1) Sys.argv.(2) then exit 0 else exit 2
+  if cmpbyt Sys.argv.(1) Sys.argv.(2) then exit 0 else exit 1

diff --git a/tools/depend.ml b/tools/depend.ml
deleted file mode 100644 (file)
index a29f843..0000000
--- a/tools/depend.ml
+++ /dev/null
@@ -1,515 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Asttypes
-open Location
-open Longident
-open Parsetree
-
-module StringSet = Set.Make(struct type t = string let compare = compare end)
-module StringMap = Map.Make(String)
-
-(* Module resolution map *)
-(* Node (set of imports for this path, map for submodules) *)
-type map_tree = Node of StringSet.t * bound_map
-and  bound_map = map_tree StringMap.t
-let bound = Node (StringSet.empty, StringMap.empty)
-
-(*let get_free (Node (s, _m)) = s*)
-let get_map (Node (_s, m)) = m
-let make_leaf s = Node (StringSet.singleton s, StringMap.empty)
-let make_node m =  Node (StringSet.empty, m)
-let rec weaken_map s (Node(s0,m0)) =
-  Node (StringSet.union s s0, StringMap.map (weaken_map s) m0)
-let rec collect_free (Node (s, m)) =
-  StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s
-
-(* Returns the imports required to access the structure at path p *)
-(* Only raises Not_found if the head of p is not in the toplevel map *)
-let rec lookup_free p m =
-  match p with
-    [] -> raise Not_found
-  | s::p ->
-      let Node (f, m') = StringMap.find s m  in
-      try lookup_free p m' with Not_found -> f
-
-(* Returns the node corresponding to the structure at path p *)
-let rec lookup_map lid m =
-  match lid with
-    Lident s    -> StringMap.find s m
-  | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m))
-  | Lapply _    -> raise Not_found
-
-(* Collect free module identifiers in the a.s.t. *)
-
-let free_structure_names = ref StringSet.empty
-
-let add_names s =
-  free_structure_names := StringSet.union s !free_structure_names
-
-let rec add_path bv ?(p=[]) = function
-  | Lident s ->
-      let free =
-        try lookup_free (s::p) bv with Not_found -> StringSet.singleton s
-      in
-      (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free;
-        prerr_endline "";*)
-      add_names free
-  | Ldot(l, s) -> add_path bv ~p:(s::p) l
-  | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
-
-let open_module bv lid =
-  match lookup_map lid bv with
-  | Node (s, m) ->
-      add_names s;
-      StringMap.fold StringMap.add m bv
-  | exception Not_found ->
-      add_path bv lid; bv
-
-let add_parent bv lid =
-  match lid.txt with
-    Ldot(l, _s) -> add_path bv l
-  | _ -> ()
-
-let add = add_parent
-
-let addmodule bv lid = add_path bv lid.txt
-
-let handle_extension ext =
-  match (fst ext).txt with
-  | "error" | "ocaml.error" ->
-    raise (Location.Error
-             (Builtin_attributes.error_of_extension ext))
-  | _ ->
-    ()
-
-let rec add_type bv ty =
-  match ty.ptyp_desc with
-    Ptyp_any -> ()
-  | Ptyp_var _ -> ()
-  | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
-  | Ptyp_tuple tl -> List.iter (add_type bv) tl
-  | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
-  | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl
-  | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
-  | Ptyp_alias(t, _) -> add_type bv t
-  | Ptyp_variant(fl, _, _) ->
-      List.iter
-        (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl
-          | Rinherit sty -> add_type bv sty)
-        fl
-  | Ptyp_poly(_, t) -> add_type bv t
-  | Ptyp_package pt -> add_package_type bv pt
-  | Ptyp_extension e -> handle_extension e
-
-and add_package_type bv (lid, l) =
-  add bv lid;
-  List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
-
-let add_opt add_fn bv = function
-    None -> ()
-  | Some x -> add_fn bv x
-
-let add_constructor_arguments bv = function
-  | Pcstr_tuple l -> List.iter (add_type bv) l
-  | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
-
-let add_constructor_decl bv pcd =
-  add_constructor_arguments bv pcd.pcd_args;
-  Misc.may (add_type bv) pcd.pcd_res
-
-let add_type_declaration bv td =
-  List.iter
-    (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
-    td.ptype_cstrs;
-  add_opt add_type bv td.ptype_manifest;
-  let add_tkind = function
-    Ptype_abstract -> ()
-  | Ptype_variant cstrs ->
-      List.iter (add_constructor_decl bv) cstrs
-  | Ptype_record lbls ->
-      List.iter (fun pld -> add_type bv pld.pld_type) lbls
-  | Ptype_open -> () in
-  add_tkind td.ptype_kind
-
-let add_extension_constructor bv ext =
-  match ext.pext_kind with
-    Pext_decl(args, rty) ->
-      add_constructor_arguments bv args;
-      Misc.may (add_type bv) rty
-  | Pext_rebind lid -> add bv lid
-
-let add_type_extension bv te =
-  add bv te.ptyext_path;
-  List.iter (add_extension_constructor bv) te.ptyext_constructors
-
-let rec add_class_type bv cty =
-  match cty.pcty_desc with
-    Pcty_constr(l, tyl) ->
-      add bv l; List.iter (add_type bv) tyl
-  | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } ->
-      add_type bv ty;
-      List.iter (add_class_type_field bv) fieldl
-  | Pcty_arrow(_, ty1, cty2) ->
-      add_type bv ty1; add_class_type bv cty2
-  | Pcty_extension e -> handle_extension e
-
-and add_class_type_field bv pctf =
-  match pctf.pctf_desc with
-    Pctf_inherit cty -> add_class_type bv cty
-  | Pctf_val(_, _, _, ty) -> add_type bv ty
-  | Pctf_method(_, _, _, ty) -> add_type bv ty
-  | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
-  | Pctf_attribute _ -> ()
-  | Pctf_extension e -> handle_extension e
-
-let add_class_description bv infos =
-  add_class_type bv infos.pci_expr
-
-let add_class_type_declaration = add_class_description
-
-let pattern_bv = ref StringMap.empty
-
-let rec add_pattern bv pat =
-  match pat.ppat_desc with
-    Ppat_any -> ()
-  | Ppat_var _ -> ()
-  | Ppat_alias(p, _) -> add_pattern bv p
-  | Ppat_interval _
-  | Ppat_constant _ -> ()
-  | Ppat_tuple pl -> List.iter (add_pattern bv) pl
-  | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op
-  | Ppat_record(pl, _) ->
-      List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl
-  | Ppat_array pl -> List.iter (add_pattern bv) pl
-  | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2
-  | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty
-  | Ppat_variant(_, op) -> add_opt add_pattern bv op
-  | Ppat_type li -> add bv li
-  | Ppat_lazy p -> add_pattern bv p
-  | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv
-  | Ppat_exception p -> add_pattern bv p
-  | Ppat_extension e -> handle_extension e
-
-let add_pattern bv pat =
-  pattern_bv := bv;
-  add_pattern bv pat;
-  !pattern_bv
-
-let rec add_expr bv exp =
-  match exp.pexp_desc with
-    Pexp_ident l -> add bv l
-  | Pexp_constant _ -> ()
-  | Pexp_let(rf, pel, e) ->
-      let bv = add_bindings rf bv pel in add_expr bv e
-  | Pexp_fun (_, opte, p, e) ->
-      add_opt add_expr bv opte; add_expr (add_pattern bv p) e
-  | Pexp_function pel ->
-      add_cases bv pel
-  | Pexp_apply(e, el) ->
-      add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el
-  | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel
-  | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel
-  | Pexp_tuple el -> List.iter (add_expr bv) el
-  | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte
-  | Pexp_variant(_, opte) -> add_opt add_expr bv opte
-  | Pexp_record(lblel, opte) ->
-      List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel;
-      add_opt add_expr bv opte
-  | Pexp_field(e, fld) -> add_expr bv e; add bv fld
-  | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2
-  | Pexp_array el -> List.iter (add_expr bv) el
-  | Pexp_ifthenelse(e1, e2, opte3) ->
-      add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3
-  | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2
-  | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2
-  | Pexp_for( _, e1, e2, _, e3) ->
-      add_expr bv e1; add_expr bv e2; add_expr bv e3
-  | Pexp_coerce(e1, oty2, ty3) ->
-      add_expr bv e1;
-      add_opt add_type bv oty2;
-      add_type bv ty3
-  | Pexp_constraint(e1, ty2) ->
-      add_expr bv e1;
-      add_type bv ty2
-  | Pexp_send(e, _m) -> add_expr bv e
-  | Pexp_new li -> add bv li
-  | Pexp_setinstvar(_v, e) -> add_expr bv e
-  | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel
-  | Pexp_letmodule(id, m, e) ->
-      let b = add_module_binding bv m in
-      add_expr (StringMap.add id.txt b bv) e
-  | Pexp_assert (e) -> add_expr bv e
-  | Pexp_lazy (e) -> add_expr bv e
-  | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
-  | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } ->
-      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
-  | Pexp_newtype (_, e) -> add_expr bv e
-  | Pexp_pack m -> add_module bv m
-  | Pexp_open (_ovf, m, e) ->
-      let bv = open_module bv m.txt in add_expr bv e
-  | Pexp_extension (({ txt = ("ocaml.extension_constructor"|
-                              "extension_constructor"); _ },
-                     PStr [item]) as e) ->
-      begin match item.pstr_desc with
-      | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c
-      | _ -> handle_extension e
-      end
-  | Pexp_extension e -> handle_extension e
-  | Pexp_unreachable -> ()
-
-and add_cases bv cases =
-  List.iter (add_case bv) cases
-
-and add_case bv {pc_lhs; pc_guard; pc_rhs} =
-  let bv = add_pattern bv pc_lhs in
-  add_opt add_expr bv pc_guard;
-  add_expr bv pc_rhs
-
-and add_bindings recf bv pel =
-  let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in
-  let bv = if recf = Recursive then bv' else bv in
-  List.iter (fun x -> add_expr bv x.pvb_expr) pel;
-  bv'
-
-and add_modtype bv mty =
-  match mty.pmty_desc with
-    Pmty_ident l -> add bv l
-  | Pmty_alias l -> addmodule bv l
-  | Pmty_signature s -> add_signature bv s
-  | Pmty_functor(id, mty1, mty2) ->
-      Misc.may (add_modtype bv) mty1;
-      add_modtype (StringMap.add id.txt bound bv) mty2
-  | Pmty_with(mty, cstrl) ->
-      add_modtype bv mty;
-      List.iter
-        (function
-          | Pwith_type (_, td) -> add_type_declaration bv td
-          | Pwith_module (_, lid) -> addmodule bv lid
-          | Pwith_typesubst td -> add_type_declaration bv td
-          | Pwith_modsubst (_, lid) -> addmodule bv lid
-        )
-        cstrl
-  | Pmty_typeof m -> add_module bv m
-  | Pmty_extension e -> handle_extension e
-
-and add_module_alias bv l =
-  try
-    add_parent bv l;
-    lookup_map l.txt bv
-  with Not_found ->
-    match l.txt with
-      Lident s -> make_leaf s
-    | _ -> addmodule bv l; bound (* cannot delay *)
-
-and add_modtype_binding bv mty =
-  if not !Clflags.transparent_modules then add_modtype bv mty;
-  match mty.pmty_desc with
-    Pmty_alias l ->
-      add_module_alias bv l
-  | Pmty_signature s ->
-      make_node (add_signature_binding bv s)
-  | Pmty_typeof modl ->
-      add_module_binding bv modl
-  | _ ->
-      if !Clflags.transparent_modules then add_modtype bv mty; bound
-
-and add_signature bv sg =
-  ignore (add_signature_binding bv sg)
-
-and add_signature_binding bv sg =
-  snd (List.fold_left add_sig_item (bv, StringMap.empty) sg)
-
-and add_sig_item (bv, m) item =
-  match item.psig_desc with
-    Psig_value vd ->
-      add_type bv vd.pval_type; (bv, m)
-  | Psig_type (_, dcls) ->
-      List.iter (add_type_declaration bv) dcls; (bv, m)
-  | Psig_typext te ->
-      add_type_extension bv te; (bv, m)
-  | Psig_exception pext ->
-      add_extension_constructor bv pext; (bv, m)
-  | Psig_module pmd ->
-      let m' = add_modtype_binding bv pmd.pmd_type in
-      let add = StringMap.add pmd.pmd_name.txt m' in
-      (add bv, add m)
-  | Psig_recmodule decls ->
-      let add =
-        List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound)
-                        decls
-      in
-      let bv' = add bv and m' = add m in
-      List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls;
-      (bv', m')
-  | Psig_modtype x ->
-      begin match x.pmtd_type with
-        None -> ()
-      | Some mty -> add_modtype bv mty
-      end;
-      (bv, m)
-  | Psig_open od ->
-      (open_module bv od.popen_lid.txt, m)
-  | Psig_include incl ->
-      let Node (s, m') = add_modtype_binding bv incl.pincl_mod in
-      add_names s;
-      let add = StringMap.fold StringMap.add m' in
-      (add bv, add m)
-  | Psig_class cdl ->
-      List.iter (add_class_description bv) cdl; (bv, m)
-  | Psig_class_type cdtl ->
-      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
-  | Psig_attribute _ -> (bv, m)
-  | Psig_extension (e, _) ->
-      handle_extension e;
-      (bv, m)
-
-and add_module_binding bv modl =
-  if not !Clflags.transparent_modules then add_module bv modl;
-  match modl.pmod_desc with
-    Pmod_ident l ->
-      begin try
-        add_parent bv l;
-        lookup_map l.txt bv
-      with Not_found ->
-        match l.txt with
-          Lident s -> make_leaf s
-        | _ ->  addmodule bv l; bound
-      end
-  | Pmod_structure s ->
-      make_node (snd (add_structure_binding bv s))
-  | _ ->
-      if !Clflags.transparent_modules then add_module bv modl; bound
-
-and add_module bv modl =
-  match modl.pmod_desc with
-    Pmod_ident l -> addmodule bv l
-  | Pmod_structure s -> ignore (add_structure bv s)
-  | Pmod_functor(id, mty, modl) ->
-      Misc.may (add_modtype bv) mty;
-      add_module (StringMap.add id.txt bound bv) modl
-  | Pmod_apply(mod1, mod2) ->
-      add_module bv mod1; add_module bv mod2
-  | Pmod_constraint(modl, mty) ->
-      add_module bv modl; add_modtype bv mty
-  | Pmod_unpack(e) ->
-      add_expr bv e
-  | Pmod_extension e ->
-      handle_extension e
-
-and add_structure bv item_list =
-  let (bv, m) = add_structure_binding bv item_list in
-  add_names (collect_free (make_node m));
-  bv
-
-and add_structure_binding bv item_list =
-  List.fold_left add_struct_item (bv, StringMap.empty) item_list
-
-and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t =
-  match item.pstr_desc with
-    Pstr_eval (e, _attrs) ->
-      add_expr bv e; (bv, m)
-  | Pstr_value(rf, pel) ->
-      let bv = add_bindings rf bv pel in (bv, m)
-  | Pstr_primitive vd ->
-      add_type bv vd.pval_type; (bv, m)
-  | Pstr_type (_, dcls) ->
-      List.iter (add_type_declaration bv) dcls; (bv, m)
-  | Pstr_typext te ->
-      add_type_extension bv te;
-      (bv, m)
-  | Pstr_exception pext ->
-      add_extension_constructor bv pext; (bv, m)
-  | Pstr_module x ->
-      let b = add_module_binding bv x.pmb_expr in
-      let add = StringMap.add x.pmb_name.txt b in
-      (add bv, add m)
-  | Pstr_recmodule bindings ->
-      let add =
-        List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings
-      in
-      let bv' = add bv and m = add m in
-      List.iter
-        (fun x -> add_module bv' x.pmb_expr)
-        bindings;
-      (bv', m)
-  | Pstr_modtype x ->
-      begin match x.pmtd_type with
-        None -> ()
-      | Some mty -> add_modtype bv mty
-      end;
-      (bv, m)
-  | Pstr_open od ->
-      (open_module bv od.popen_lid.txt, m)
-  | Pstr_class cdl ->
-      List.iter (add_class_declaration bv) cdl; (bv, m)
-  | Pstr_class_type cdtl ->
-      List.iter (add_class_type_declaration bv) cdtl; (bv, m)
-  | Pstr_include incl ->
-      let Node (s, m') = add_module_binding bv incl.pincl_mod in
-      add_names s;
-      let add = StringMap.fold StringMap.add m' in
-      (add bv, add m)
-  | Pstr_attribute _ -> (bv, m)
-  | Pstr_extension (e, _) ->
-      handle_extension e;
-      (bv, m)
-
-and add_use_file bv top_phrs =
-  ignore (List.fold_left add_top_phrase bv top_phrs)
-
-and add_implementation bv l =
-  if !Clflags.transparent_modules then
-    ignore (add_structure_binding bv l)
-  else ignore (add_structure bv l)
-
-and add_implementation_binding bv l =
-  snd (add_structure_binding bv l)
-
-and add_top_phrase bv = function
-  | Ptop_def str -> add_structure bv str
-  | Ptop_dir (_, _) -> bv
-
-and add_class_expr bv ce =
-  match ce.pcl_desc with
-    Pcl_constr(l, tyl) ->
-      add bv l; List.iter (add_type bv) tyl
-  | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } ->
-      let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
-  | Pcl_fun(_, opte, pat, ce) ->
-      add_opt add_expr bv opte;
-      let bv = add_pattern bv pat in add_class_expr bv ce
-  | Pcl_apply(ce, exprl) ->
-      add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl
-  | Pcl_let(rf, pel, ce) ->
-      let bv = add_bindings rf bv pel in add_class_expr bv ce
-  | Pcl_constraint(ce, ct) ->
-      add_class_expr bv ce; add_class_type bv ct
-  | Pcl_extension e -> handle_extension e
-
-and add_class_field bv pcf =
-  match pcf.pcf_desc with
-    Pcf_inherit(_, ce, _) -> add_class_expr bv ce
-  | Pcf_val(_, _, Cfk_concrete (_, e))
-  | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e
-  | Pcf_val(_, _, Cfk_virtual ty)
-  | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty
-  | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2
-  | Pcf_initializer e -> add_expr bv e
-  | Pcf_attribute _ -> ()
-  | Pcf_extension e -> handle_extension e
-
-and add_class_declaration bv decl =
-  add_class_expr bv decl.pci_expr

diff --git a/tools/depend.mli b/tools/depend.mli
deleted file mode 100644 (file)
index e34abbe..0000000
--- a/tools/depend.mli
+++ /dev/null
@@ -1,38 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(** Module dependencies. *)
-
-module StringSet : Set.S with type elt = string
-module StringMap : Map.S with type key = string
-
-type map_tree = Node of StringSet.t * bound_map
-and  bound_map = map_tree StringMap.t
-val make_leaf : string -> map_tree
-val make_node : bound_map -> map_tree
-val weaken_map : StringSet.t -> map_tree -> map_tree
-
-val free_structure_names : StringSet.t ref
-
-val open_module : bound_map -> Longident.t -> bound_map
-
-val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit
-
-val add_signature : bound_map -> Parsetree.signature -> unit
-
-val add_implementation : bound_map -> Parsetree.structure -> unit
-
-val add_implementation_binding : bound_map -> Parsetree.structure -> bound_map
-val add_signature_binding : bound_map -> Parsetree.signature -> bound_map

diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 3c462e67b5de0ab13e605893c370d1e76dc75883..e4c8186cf4a000b0bcfe709305ba807b57bf388a 100644 (file)
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -26,6 +26,7 @@ open Cmo_format
 open Printf
 
 let print_locations = ref true
+let print_reloc_info = ref false
 
 (* Read signed and unsigned integers *)
 
@@ -497,6 +498,8 @@ let dump_obj ic =
   seek_in ic cu_pos;
   let cu = (input_value ic : compilation_unit) in
   reloc := cu.cu_reloc;
+  if !print_reloc_info then
+    List.iter print_reloc cu.cu_reloc;
   if cu.cu_debug > 0 then begin
     seek_in ic cu.cu_debug;
     let evl = (input_value ic : debug_event list) in
@@ -510,13 +513,7 @@ let dump_obj ic =
 
 let read_primitive_table ic len =
   let p = really_input_string ic len in
-  let rec split beg cur =
-    if cur >= len then []
-    else if p.[cur] = '\000' then
-      String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
-    else
-      split beg (cur + 1) in
-  Array.of_list(split 0 0)
+  String.split_on_char '\000' p |> List.filter ((<>) "") |> Array.of_list
 
 (* Print an executable file *)
 
@@ -549,6 +546,7 @@ let dump_exe ic =
 
 let arg_list = [
   "-noloc", Arg.Clear print_locations, " : don't print source information";
+  "-reloc", Arg.Set print_reloc_info, " : print relocation information";
 ]
 let arg_usage =
   Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files"

diff --git a/tools/lexer299.mll b/tools/lexer299.mll
index 6ff82a893b998dff8145761068e9fd74c93b8f37..134539991b0f0e79f12e47573319e924be7a900b 100644 (file)
--- a/tools/lexer299.mll
+++ b/tools/lexer299.mll
@@ -58,6 +58,7 @@ type token =
   | GREATER
   | GREATERRBRACE
   | GREATERRBRACKET
+  | HASH
   | IF
   | IN
   | INCLUDE
@@ -104,7 +105,6 @@ type token =
   | RPAREN
   | SEMI
   | SEMISEMI
-  | SHARP
   | SIG
   | STAR
   | STRING of (string)
@@ -345,7 +345,7 @@ rule token = parse
   | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
       (* # linenum ...  *)
       { token lexbuf }
-  | "#"  { SHARP }
+  | "#"  { HASH }
   | "&"  { AMPERSAND }
   | "&&" { AMPERAMPER }
   | "`"  { BACKQUOTE }

diff --git a/tools/lexer301.mll b/tools/lexer301.mll
index 3823952ede258d621cfc4bc36c95b395cab88edd..e574c365687c0f9b70c8a019b0e53198c5011c22 100644 (file)
--- a/tools/lexer301.mll
+++ b/tools/lexer301.mll
@@ -57,6 +57,7 @@ type token =
   | GREATER
   | GREATERRBRACE
   | GREATERRBRACKET
+  | HASH
   | IF
   | IN
   | INCLUDE
@@ -106,7 +107,6 @@ type token =
   | RPAREN
   | SEMI
   | SEMISEMI
-  | SHARP
   | SIG
   | STAR
   | STRING of (string)
@@ -346,7 +346,7 @@ rule token = parse
   | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n")
       (* # linenum ...  *)
       { token lexbuf }
-  | "#"  { SHARP }
+  | "#"  { HASH }
   | "&"  { AMPERSAND }
   | "&&" { AMPERAMPER }
   | "`"  { BACKQUOTE }

diff --git a/tools/objinfo.ml b/tools/objinfo.ml
index 30bc353d502cae89a728c1af808fe47c5cfd7fe4..924f61fe6e51868986288a84f27ddc9e5631479e 100644 (file)
--- a/tools/objinfo.ml
+++ b/tools/objinfo.ml
@@ -49,10 +49,15 @@ let print_name_crc (name, crco) =
 let print_line name =
   printf "\t%s\n" name
 
+let print_required_global id =
+  printf "\t%s\n" (Ident.name id)
+
 let print_cmo_infos cu =
   printf "Unit name: %s\n" cu.cu_name;
   print_string "Interfaces imported:\n";
   List.iter print_name_crc cu.cu_imports;
+  print_string "Required globals:\n";
+  List.iter print_required_global cu.cu_required_globals;
   printf "Uses unsafe features: ";
   (match cu.cu_primitives with
     | [] -> printf "no\n"

diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index 5508b179a2ffb22f2752051d1c44d8cb5528e943..22d1e29aaec3a5df2a1009f67220c109ebc63a07 100644 (file)
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -86,6 +86,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _output_obj = option "-output-obj"
   let _output_complete_obj = option "-output-complete-obj"
   let _pack = option "-pack"
+  let _plugin = option_with_arg "-plugin"
   let _pp _s = incompatible "-pp"
   let _ppx _s = incompatible "-ppx"
   let _principal = option "-principal"
@@ -101,6 +102,8 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _no_strict_formats = option "-no-strict-formats"
   let _thread () = option "-thread" ()
   let _vmthread () = option "-vmthread" ()
+  let _unboxed_types = option "-unboxed-types"
+  let _no_unboxed_types = option "-no-unboxed-types"
   let _unsafe = option "-unsafe"
   let _unsafe_string = option "-unsafe-string"
   let _use_prims s = option_with_arg "-use-prims" s

diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 6e102e9b0c21a3073cf7b586c924efa859dc5aeb..4fd3f1cfa0a0564e5ed90b85071a3291d36f8dcc 100644 (file)
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -26,6 +26,7 @@ let load_path = ref ([] : (string * string array) list)
 let ml_synonyms = ref [".ml"]
 let mli_synonyms = ref [".mli"]
 let native_only = ref false
+let bytecode_only = ref false
 let error_occurred = ref false
 let raw_dependencies = ref false
 let sort_files = ref false
@@ -279,21 +280,21 @@ let read_and_approximate inputfile =
     report_err exn;
     !Depend.free_structure_names
 
-let read_parse_and_extract parse_function extract_function def magic
-    source_file =
+let read_parse_and_extract parse_function extract_function def ast_kind
+                           source_file =
   Depend.free_structure_names := Depend.StringSet.empty;
   try
     let input_file = Pparse.preprocess source_file in
     begin try
       let ast =
         Pparse.file ~tool_name Format.err_formatter
-                    input_file parse_function magic
+                    input_file parse_function ast_kind
       in
       let bound_vars =
         List.fold_left
           (fun bv modname ->
             Depend.open_module bv (Longident.Lident modname))
-          !module_map !Clflags.open_modules
+          !module_map ((* PR#7248 *) List.rev !Clflags.open_modules)
       in
       let r = extract_function bound_vars ast in
       Pparse.remove_preprocessed input_file;
@@ -309,6 +310,46 @@ let read_parse_and_extract parse_function extract_function def magic
     else (read_and_approximate source_file, def)
   end
 
+let print_ml_dependencies source_file extracted_deps =
+  let basename = Filename.chop_extension source_file in
+  let byte_targets = [ basename ^ ".cmo" ] in
+  let native_targets =
+    if !all_dependencies
+    then [ basename ^ ".cmx"; basename ^ ".o" ]
+    else [ basename ^ ".cmx" ] in
+  let init_deps = if !all_dependencies then [source_file] else [] in
+  let cmi_name = basename ^ ".cmi" in
+  let init_deps, extra_targets =
+    if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
+        !mli_synonyms
+    then (cmi_name :: init_deps, cmi_name :: init_deps), []
+    else (init_deps, init_deps),
+         (if !all_dependencies then [cmi_name] else [])
+  in
+  let (byt_deps, native_deps) =
+    Depend.StringSet.fold (find_dependency ML)
+      extracted_deps init_deps in
+  if not !native_only then
+    print_dependencies (byte_targets @ extra_targets) byt_deps;
+  if not !bytecode_only then
+    print_dependencies (native_targets @ extra_targets) native_deps
+
+let print_mli_dependencies source_file extracted_deps =
+  let basename = Filename.chop_extension source_file in
+  let (byt_deps, _opt_deps) =
+    Depend.StringSet.fold (find_dependency MLI)
+      extracted_deps ([], []) in
+  print_dependencies [basename ^ ".cmi"] byt_deps
+
+let print_file_dependencies (source_file, kind, extracted_deps) =
+  if !raw_dependencies then begin
+    print_raw_dependencies source_file extracted_deps
+  end else
+    match kind with
+    | ML -> print_ml_dependencies source_file extracted_deps
+    | MLI -> print_mli_dependencies source_file extracted_deps
+
+
 let ml_file_dependencies source_file =
   let parse_use_file_as_impl lexbuf =
     let f x =
@@ -320,54 +361,16 @@ let ml_file_dependencies source_file =
   in
   let (extracted_deps, ()) =
     read_parse_and_extract parse_use_file_as_impl Depend.add_implementation ()
-                           Config.ast_impl_magic_number source_file
+                           Pparse.Structure source_file
   in
-  if !sort_files then
-    files := (source_file, ML, !Depend.free_structure_names) :: !files
-  else
-    if !raw_dependencies then begin
-      print_raw_dependencies source_file extracted_deps
-    end else begin
-      let basename = Filename.chop_extension source_file in
-      let byte_targets = [ basename ^ ".cmo" ] in
-      let native_targets =
-        if !all_dependencies
-        then [ basename ^ ".cmx"; basename ^ ".o" ]
-        else [ basename ^ ".cmx" ] in
-      let init_deps = if !all_dependencies then [source_file] else [] in
-      let cmi_name = basename ^ ".cmi" in
-      let init_deps, extra_targets =
-        if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
-                       !mli_synonyms
-        then (cmi_name :: init_deps, cmi_name :: init_deps), []
-        else (init_deps, init_deps),
-             (if !all_dependencies then [cmi_name] else [])
-      in
-      let (byt_deps, native_deps) =
-        Depend.StringSet.fold (find_dependency ML)
-          extracted_deps init_deps in
-      if not !native_only then
-        print_dependencies (byte_targets @ extra_targets) byt_deps;
-      print_dependencies (native_targets @ extra_targets) native_deps;
-    end
+  files := (source_file, ML, extracted_deps) :: !files
 
 let mli_file_dependencies source_file =
   let (extracted_deps, ()) =
     read_parse_and_extract Parse.interface Depend.add_signature ()
-                           Config.ast_intf_magic_number source_file
+                           Pparse.Signature source_file
   in
-  if !sort_files then
-    files := (source_file, MLI, extracted_deps) :: !files
-  else
-    if !raw_dependencies then begin
-      print_raw_dependencies source_file extracted_deps
-    end else begin
-      let basename = Filename.chop_extension source_file in
-      let (byt_deps, _opt_deps) =
-        Depend.StringSet.fold (find_dependency MLI)
-          extracted_deps ([], []) in
-      print_dependencies [basename ^ ".cmi"] byt_deps
-    end
+  files := (source_file, MLI, extracted_deps) :: !files
 
 let process_file_as process_fun def source_file =
   Compenv.readenv ppf (Before_compile source_file);
@@ -493,11 +496,11 @@ let rec dump_map s0 ppf m =
 
 let process_ml_map =
   read_parse_and_extract Parse.implementation Depend.add_implementation_binding
-                         StringMap.empty Config.ast_impl_magic_number
+                         StringMap.empty Pparse.Structure
 
 let process_mli_map =
   read_parse_and_extract Parse.interface Depend.add_signature_binding
-                         StringMap.empty Config.ast_intf_magic_number
+                         StringMap.empty Pparse.Signature
 
 let parse_map fname =
   map_files := fname :: !map_files ;
@@ -571,6 +574,8 @@ let _ =
         " Print module dependencies in raw form (not suitable for make)";
      "-native", Arg.Set native_only,
         " Generate dependencies for native-code only (no .cmo files)";
+     "-bytecode", Arg.Set bytecode_only,
+        " Generate dependencies for bytecode-code only (no .cmx files)";
      "-one-line", Arg.Set one_line,
         " Output one line per file, regardless of the length";
      "-open", Arg.String (add_to_list Clflags.open_modules),
@@ -589,5 +594,6 @@ let _ =
          " Print version number and exit";
     ] file_dependencies usage;
   Compenv.readenv ppf Before_link;
-  if !sort_files then sort_files_by_dependencies !files;
+  if !sort_files then sort_files_by_dependencies !files
+  else List.iter print_file_dependencies (List.sort compare !files);
   exit (if !error_occurred then 2 else 0)

diff --git a/tools/ocamlmktop.ml b/tools/ocamlmktop.ml
index 30b9d50b4f1d16311e46859d60b6af10bd94572c..ab333966a463f7efdfd7eacae0590f1240fefd87 100644 (file)
--- a/tools/ocamlmktop.ml
+++ b/tools/ocamlmktop.ml
@@ -15,6 +15,18 @@
 
 let _ =
   let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in
-  exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma \
-                    ocamlbytecomp.cma ocamltoplevel.cma "
-                   ^ args ^ " topstart.cmo"))
+  let ocamlmktop = Sys.executable_name in
+  (* On Windows Sys.command calls system() which in turn calls 'cmd.exe /c'.
+     cmd.exe has special quoting rules (see 'cmd.exe /?' for details).
+     Short version: if the string passed to cmd.exe starts with '"',
+     the first and last '"' are removed *)
+  let ocamlc,extra_quote =
+    if Sys.win32 then "ocamlc.exe","\"" else "ocamlc",""
+  in
+  let ocamlc = Filename.(quote (concat (dirname ocamlmktop) ocamlc)) in
+  let cmdline =
+    extra_quote ^ ocamlc ^ " -I +compiler-libs -linkall ocamlcommon.cma " ^
+    "ocamlbytecomp.cma ocamltoplevel.cma " ^ args ^ " topstart.cmo" ^
+    extra_quote
+  in
+  exit(Sys.command cmdline)

diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl
deleted file mode 100644 (file)
index f9d9fae..0000000
--- a/tools/ocamlmktop.tpl
+++ /dev/null
@@ -1,18 +0,0 @@
-#!/bin/sh
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Damien Doligez, projet Para, INRIA Rocquencourt             *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma \
-                       ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo

diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index b96d28348c2a7177298a21cef0bd1d24cb3f76f0..188674af4e63d75f328f383b20398c66823d8942 100644 (file)
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -108,6 +108,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _output_complete_obj = option "-output-complete-obj"
   let _p = option "-p"
   let _pack = option "-pack"
+  let _plugin = option_with_arg "-plugin"
   let _pp _s = incompatible "-pp"
   let _ppx _s = incompatible "-ppx"
   let _principal = option "-principal"
@@ -127,6 +128,8 @@ module Options = Main_args.Make_optcomp_options (struct
   let _thread = option "-thread"
   let _unbox_closures = option "-unbox-closures"
   let _unbox_closures_factor = option_with_int "-unbox-closures"
+  let _unboxed_types = option "-unboxed-types"
+  let _no_unboxed_types = option "-no-unboxed-types"
   let _unsafe = option "-unsafe"
   let _unsafe_string = option "-unsafe-string"
   let _v = option "-v"

diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 68e7d9b0af14340c94c672f1cc3b9bb513896e5e..0a22fa4677504b0e0d4a067731c9c8f60650d172 100644 (file)
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -284,6 +284,9 @@ and rw_exp iflag sexp =
       rewrite_mod iflag smod;
       rewrite_exp iflag sexp
 
+  | Pexp_letexception (_cd, exp) ->
+      rewrite_exp iflag exp
+
   | Pexp_assert (cond) -> rewrite_exp iflag cond
 
   | Pexp_lazy (expr) -> rewrite_exp iflag expr

diff --git a/tools/primreq.ml b/tools/primreq.ml
index fc7dcf22a03264f3e0392005084c002badbb0630..bef375fc3387ec4309b07b325b1d9fa6a8d9b944 100644 (file)
--- a/tools/primreq.ml
+++ b/tools/primreq.ml
@@ -40,8 +40,7 @@ let scan_info cu =
 
 let scan_obj filename =
   let ic = open_in_bin filename in
-  let buffer = String.create (String.length cmo_magic_number) in
-  really_input ic buffer 0 (String.length cmo_magic_number);
+  let buffer = really_input_string ic (String.length cmo_magic_number) in
   if buffer = cmo_magic_number then begin
     let cu_pos = input_binary_int ic in
     seek_in ic cu_pos;

diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml
index 47c370d896761cbf2d89c49512844ee10e94bb6a..e97d8e593b46cdf51fdbbb3ba5fe86a4da122504 100644 (file)
--- a/toplevel/expunge.ml
+++ b/toplevel/expunge.ml
@@ -41,7 +41,7 @@ let expunge_map tbl =
   Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl
 
 let expunge_crcs tbl =
-  List.filter (fun (unit, crc) -> keep unit) tbl
+  List.filter (fun (unit, _crc) -> keep unit) tbl
 
 let main () =
   let input_name = Sys.argv.(1) in

diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index dc7c8d88dbb12c6560bc4c89d11af59fbef1a846..28682a9d092b0af01f2693aa03753b47acf7dc8a 100644 (file)
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -77,7 +77,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         let hash x =
           try
             Hashtbl.hash x
-          with exn -> 0
+          with _exn -> 0
       end)
 
 
@@ -159,7 +159,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
 
     let install_printer path ty fn =
       let print_val ppf obj =
-        try fn ppf obj with exn -> exn_printer ppf path in
+        try fn ppf obj with _exn -> exn_printer ppf path in
       let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in
       printers := (path, Simple (ty, printer)) :: !printers
 
@@ -196,9 +196,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
 
     let tree_of_qualified lookup_fun env ty_path name =
       match ty_path with
-      | Pident id ->
+      | Pident _ ->
           Oide_ident name
-      | Pdot(p, s, pos) ->
+      | Pdot(p, _s, _pos) ->
           if try
                match (lookup_fun (Lident name) env).desc with
                | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
@@ -206,7 +206,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
              with Not_found -> false
           then Oide_ident name
           else Oide_dot (Printtyp.tree_of_path p, name)
-      | Papply(p1, p2) ->
+      | Papply _ ->
           Printtyp.tree_of_path ty_path
 
     let tree_of_constr =
@@ -255,7 +255,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
           match (Ctype.repr ty).desc with
           | Tvar _ | Tunivar _ ->
               Oval_stuff "<poly>"
-          | Tarrow(_, ty1, ty2, _) ->
+          | Tarrow _ ->
               Oval_stuff "<fun>"
           | Ttuple(ty_list) ->
               Oval_tuple (tree_of_val_list 0 depth obj ty_list)
@@ -365,9 +365,11 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                     tree_of_val depth obj
                       (try Ctype.apply env decl.type_params body ty_list with
                          Ctype.Cannot_apply -> abstract_type)
-                | {type_kind = Type_variant constr_list} ->
+                | {type_kind = Type_variant constr_list; type_unboxed} ->
+                    let unbx = type_unboxed.unboxed in
                     let tag =
-                      if O.is_block obj
+                      if unbx then Cstr_unboxed
+                      else if O.is_block obj
                       then Cstr_block(O.tag obj)
                       else Cstr_constant(O.obj obj) in
                     let {cd_id;cd_args;cd_res} =
@@ -393,12 +395,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                           in
                           tree_of_constr_with_args (tree_of_constr env path)
                             (Ident.name cd_id) false 0 depth obj
-                            ty_args
+                            ty_args unbx
                       | Cstr_record lbls ->
                           let r =
                             tree_of_record_fields depth
                               env path type_params ty_list
-                              lbls 0 obj
+                              lbls 0 obj unbx
                           in
                           Oval_constr(tree_of_constr env path
                                         (Ident.name cd_id),
@@ -413,9 +415,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                           | Record_extension -> 1
                           | _ -> 0
                         in
+                        let unbx =
+                          match rep with Record_unboxed _ -> true | _ -> false
+                        in
                         tree_of_record_fields depth
                           env path decl.type_params ty_list
-                          lbl_list pos obj
+                          lbl_list pos obj unbx
                     end
                 | {type_kind = Type_open} ->
                     tree_of_extension path depth obj
@@ -464,7 +469,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         end
 
       and tree_of_record_fields depth env path type_params ty_list
-          lbl_list pos obj =
+          lbl_list pos obj unboxed =
         let rec tree_of_fields pos = function
           | [] -> []
           | {ld_id; ld_type} :: remainder ->
@@ -481,8 +486,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                 if pos = 0 then tree_of_label env path name
                 else Oide_ident name
               and v =
-                nest tree_of_val (depth - 1) (O.field obj pos)
-                  ty_arg
+                if unboxed
+                then tree_of_val (depth - 1) obj ty_arg
+                else nest tree_of_val (depth - 1) (O.field obj pos) ty_arg
               in
               (lid, v) :: tree_of_fields (pos + 1) remainder
         in
@@ -497,10 +503,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
       tree_list start ty_list
 
       and tree_of_constr_with_args
-             tree_of_cstr cstr_name inlined start depth obj ty_args =
+             tree_of_cstr cstr_name inlined start depth obj ty_args unboxed =
         let lid = tree_of_cstr cstr_name in
         let args =
-          if inlined then
+          if inlined || unboxed then
             match ty_args with
             | [ty] -> [ tree_of_val (depth - 1) obj ty ]
             | _ -> assert false
@@ -533,7 +539,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         tree_of_constr_with_args
            (fun x -> Oide_ident x) name (cstr.cstr_inlined <> None)
            1 depth bucket
-           cstr.cstr_args
+           cstr.cstr_args false
       with Not_found | EVP.Error ->
         match check_depth depth bucket ty with
           Some x -> x
@@ -545,15 +551,15 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
     and find_printer depth env ty =
       let rec find = function
       | [] -> raise Not_found
-      | (name, Simple (sch, printer)) :: remainder ->
+      | (_name, Simple (sch, printer)) :: remainder ->
           if Ctype.moregeneral env false sch ty
           then printer
           else find remainder
-      | (name, Generic (path, fn)) :: remainder ->
+      | (_name, Generic (path, fn)) :: remainder ->
           begin match (Ctype.expand_head env ty).desc with
           | Tconstr (p, args, _) when Path.same p path ->
               begin try apply_generic_printer path (fn depth) args
-              with _ -> (fun obj -> out_exn path) end
+              with _ -> (fun _obj -> out_exn path) end
           | _ -> find remainder end in
       find !printers
 
@@ -564,7 +570,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
           let printer = fn (fun depth obj -> tree_of_val depth obj arg) in
           apply_generic_printer path printer args
       | _ ->
-          (fun obj ->
+          (fun _obj ->
             let printer ppf =
               fprintf ppf "<internal error: incorrect arity for '%a'>"
                 Printtyp.path path in

diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml
index cb155ff01decb127d9e2d73426804bbcefcd8f7b..795c7e48c5b395e27c2f10ac8151db306e688c9a 100644 (file)
--- a/toplevel/opttopdirs.ml
+++ b/toplevel/opttopdirs.ml
@@ -81,11 +81,11 @@ let load_file ppf name0 =
       (* The Dynlink interface does not allow us to distinguish between
           a Dynlink.Error exceptions raised in the loaded modules
           or a genuine error during dynlink... *)
-      try Dynlink.loadfile fn; true
+      try Compdynlink.loadfile fn; true
       with
-      | Dynlink.Error err ->
+      | Compdynlink.Error err ->
         fprintf ppf "Error while loading %s: %s.@."
-          name (Dynlink.error_message err);
+          name (Compdynlink.error_message err);
         false
       | exn ->
         print_exception_outcome ppf exn;
@@ -111,9 +111,9 @@ type 'a printer_type_new = Format.formatter -> 'a -> unit
 type 'a printer_type_old = 'a -> unit
 
 let match_printer_type ppf desc typename =
-  let (printer_type, _) =
+  let printer_type =
     try
-      Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env
+      Env.lookup_type (Ldot(Lident "Opttopdirs", typename)) !toplevel_env
     with Not_found ->
       fprintf ppf "Cannot find type Topdirs.%s.@." typename;
       raise Exit in
@@ -151,7 +151,7 @@ let dir_install_printer ppf lid =
     let v = eval_path !toplevel_env path in
     let print_function =
       if is_old_style then
-        (fun formatter repr -> Obj.obj v (Obj.obj repr))
+        (fun _formatter repr -> Obj.obj v (Obj.obj repr))
       else
         (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
     install_printer path ty_arg print_function
@@ -159,7 +159,7 @@ let dir_install_printer ppf lid =
 
 let dir_remove_printer ppf lid =
   try
-    let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
+    let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
     begin try
       remove_printer path
     with Not_found ->

diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index 628aee7c7e38ce2d53dfe174fa2f373ed0921db4..32e9905f32234e91f07051796c9123e02e745d71 100644 (file)
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -84,8 +84,12 @@ let close_phrase lam =
   let open Lambda in
   IdentSet.fold (fun id l ->
     let glb, pos = toplevel_value id in
-    let glob = Lprim (Pfield pos, [Lprim (Pgetglobal glb, [])]) in
-    Llet(Strict, id, glob, l)
+    let glob =
+      Lprim (Pfield pos,
+             [Lprim (Pgetglobal glb, [], Location.none)],
+             Location.none)
+    in
+    Llet(Strict, Pgenval, id, glob, l)
   ) (free_variables lam) lam
 
 let toplevel_value id =
@@ -99,9 +103,9 @@ let rec eval_path = function
       if Ident.persistent id || Ident.global id
       then global_symbol id
       else toplevel_value id
-  | Pdot(p, s, pos) ->
+  | Pdot(p, _s, pos) ->
       Obj.field (eval_path p) pos
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Toploop.eval_path"
 
 let eval_path env path =
@@ -205,9 +209,9 @@ module Backend = struct
 end
 let backend = (module Backend : Backend_intf.S)
 
-let load_lambda ppf ~module_ident lam size =
+let load_lambda ppf ~module_ident ~required_globals lam size =
   if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
-  let slam = Simplif.simplify_lambda lam in
+  let slam = Simplif.simplify_lambda "//toplevel//" lam in
   if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
 
   let dll =
@@ -218,10 +222,11 @@ let load_lambda ppf ~module_ident lam size =
   if not Config.flambda then
     Asmgen.compile_implementation_clambda ~source_provenance:Timings.Toplevel
       ~toplevel:need_symbol fn ppf
-      { Lambda.code=lam ; main_module_block_size=size }
+      { Lambda.code=lam ; main_module_block_size=size;
+        module_ident; required_globals }
   else
     Asmgen.compile_implementation_flambda ~source_provenance:Timings.Toplevel
-      ~backend ~toplevel:need_symbol fn ppf
+      ~required_globals ~backend ~toplevel:need_symbol fn ppf
       (Middle_end.middle_end ppf
          ~source_provenance:Timings.Toplevel ~prefixname:"" ~backend ~size
          ~module_ident ~module_initializer:lam ~filename:"toplevel");
@@ -300,25 +305,26 @@ let execute_phrase print_outcome ppf phr =
       (* Why is this done? *)
       ignore (Includemod.signatures oldenv sg sg');
       Typecore.force_delayed_checks ();
-      let module_ident, res, size =
+      let module_ident, res, required_globals, size =
         if Config.flambda then
-          let ((module_ident, size), res) =
+          let { Lambda.module_ident; main_module_block_size = size;
+                required_globals; code = res } =
             Translmod.transl_implementation_flambda !phrase_name
               (str, Tcoerce_none)
           in
           remember module_ident 0 sg';
-          module_ident, close_phrase res, size
+          module_ident, close_phrase res, required_globals, size
         else
           let size, res = Translmod.transl_store_phrases !phrase_name str in
-          Ident.create_persistent !phrase_name, res, size
+          Ident.create_persistent !phrase_name, res, Ident.Set.empty, size
       in
       Warnings.check_fatal ();
       begin try
         toplevel_env := newenv;
-        let res = load_lambda ppf ~module_ident res size in
+        let res = load_lambda ppf ~required_globals ~module_ident res size in
         let out_phr =
           match res with
-          | Result v ->
+          | Result _ ->
               if Config.flambda then
                 (* CR-someday trefis: *)
                 ()
@@ -380,7 +386,7 @@ let execute_phrase print_outcome ppf phr =
                        dir_name;
                false
              end
-          | Directive_int f, Pdir_int (n, Some _) ->
+          | Directive_int _, Pdir_int (_, Some _) ->
               fprintf ppf "Wrong integer literal for directive `%s'.@."
                 dir_name;
               false
@@ -392,19 +398,6 @@ let execute_phrase print_outcome ppf phr =
               false
       end
 
-(* Temporary assignment to a reference *)
-
-let protect r newval body =
-  let oldval = !r in
-  try
-    r := newval;
-    let res = body() in
-    r := oldval;
-    res
-  with x ->
-    r := oldval;
-    raise x
-
 (* Read and execute commands from a file, or from stdin if [name] is "". *)
 
 let use_print_results = ref true
@@ -416,6 +409,9 @@ let preprocess_phrase ppf phr =
         let str =
           Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
         in
+        let str =
+          Pparse.ImplementationHooks.apply_hooks
+            { Misc.sourcefile = "//toplevel//" } str in
         Ptop_def str
     | phr -> phr
   in
@@ -437,9 +433,9 @@ let use_file ppf wrap_mod name =
     let lb = Lexing.from_channel ic in
     Location.init lb filename;
     (* Skip initial #! line if any *)
-    Lexer.skip_sharp_bang lb;
+    Lexer.skip_hash_bang lb;
     let success =
-      protect Location.input_name filename (fun () ->
+      protect_refs [ R (Location.input_name, filename) ] (fun () ->
         try
           List.iter
             (fun ph ->
@@ -462,7 +458,7 @@ let mod_use_file ppf name = use_file ppf true name
 let use_file ppf name = use_file ppf false name
 
 let use_silently ppf name =
-  protect use_print_results false (fun () -> use_file ppf name)
+  protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
 
 (* Reading function for interactive use *)
 
@@ -514,7 +510,7 @@ let refill_lexbuf buffer len =
 
 let _ =
   Sys.interactive := true;
-  Dynlink.init ();
+  Compdynlink.init ();
   Compmisc.init_path true;
   Clflags.dlcode := true;
   ()
@@ -549,7 +545,8 @@ exception PPerror
 
 let loop ppf =
   Location.formatter_for_warnings := ppf;
-  fprintf ppf "        OCaml version %s - native toplevel@.@." Config.version;
+  if not !Clflags.noversion then
+    fprintf ppf "        OCaml version %s - native toplevel@.@." Config.version;
   initialize_toplevel_env ();
   let lb = Lexing.from_function refill_lexbuf in
   Location.init lb "//toplevel//";
@@ -578,6 +575,13 @@ let loop ppf =
 
 (* Execute a script.  If [name] is "", read the script from stdin. *)
 
+let override_sys_argv args =
+  let len = Array.length args in
+  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
+  Array.blit args 0 Sys.argv 0 len;
+  Obj.truncate (Obj.repr Sys.argv) len;
+  Arg.current := 0
+
 let run_script ppf name args =
   let len = Array.length args in
   if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";

diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli
index 3ce4d1910882fd7523159d9368b5a1d84de525fb..f234b4f4cfbfdd0f14781478ba993af7d38bf2bd 100644 (file)
--- a/toplevel/opttoploop.mli
+++ b/toplevel/opttoploop.mli
@@ -120,3 +120,13 @@ val read_interactive_input : (string -> bytes -> int -> int * bool) ref
 (* Hooks for initialization *)
 
 val toplevel_startup_hook : (unit -> unit) ref
+
+(* Misc *)
+
+val override_sys_argv : string array -> unit
+(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args]
+   and reset [Arg.current] to [0].
+
+   This is called by [run_script] so that [Sys.argv] represents
+   "script.ml args..." instead of the full command line:
+   "ocamlrun unix.cma ... script.ml args...". *)

diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index 2f1795e1c3301382554adde38d1e44a40ea89396..3f5c5c005acdae91670e51094d3bf3ac1a89f124 100644 (file)
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -73,42 +73,53 @@ module Options = Main_args.Make_opttop_options (struct
   let _noinit = set noinit
   let _clambda_checks () = clambda_checks := true
   let _inline spec =
-    Float_arg_helper.parse spec ~update:inline_threshold
-      ~help_text:"Syntax: -inline <n> | <round>=<n>[,...]"
+    Float_arg_helper.parse spec
+      "Syntax: -inline <n> | <round>=<n>[,...]"
+      inline_threshold
   let _inline_indirect_cost spec =
-    Int_arg_helper.parse spec ~update:inline_indirect_cost
-      ~help_text:"Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-indirect-cost <n> | <round>=<n>[,...]"
+      inline_indirect_cost
   let _inline_toplevel spec =
-    Int_arg_helper.parse spec ~update:inline_toplevel_threshold
-      ~help_text:"Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-toplevel <n> | <round>=<n>[,...]"
+      inline_toplevel_threshold
   let _inlining_report () = inlining_report := true
   let _dump_pass pass = set_dumped_pass pass true
   let _rounds n = simplify_rounds := Some n
   let _inline_max_unroll spec =
-    Int_arg_helper.parse spec ~update:inline_max_unroll
-      ~help_text:"Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-max-unroll <n> | <round>=<n>[,...]"
+      inline_max_unroll
   let _classic_inlining () = classic_inlining := true
   let _inline_call_cost spec =
-    Int_arg_helper.parse spec ~update:inline_call_cost
-      ~help_text:"Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-call-cost <n> | <round>=<n>[,...]"
+       inline_call_cost
   let _inline_alloc_cost spec =
-    Int_arg_helper.parse spec ~update:inline_alloc_cost
-      ~help_text:"Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-alloc-cost <n> | <round>=<n>[,...]"
+      inline_alloc_cost
   let _inline_prim_cost spec =
-    Int_arg_helper.parse spec ~update:inline_prim_cost
-      ~help_text:"Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-prim-cost <n> | <round>=<n>[,...]"
+       inline_prim_cost
   let _inline_branch_cost spec =
-    Int_arg_helper.parse spec ~update:inline_branch_cost
-      ~help_text:"Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-branch-cost <n> | <round>=<n>[,...]"
+      inline_branch_cost
   let _inline_lifting_benefit spec =
-    Int_arg_helper.parse spec ~update:inline_lifting_benefit
-      ~help_text:"Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-lifting-benefit <n> | <round>=<n>[,...]"
+      inline_lifting_benefit
   let _inline_branch_factor spec =
-    Float_arg_helper.parse spec ~update:inline_branch_factor
-      ~help_text:"Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
+    Float_arg_helper.parse spec
+      "Syntax: -inline-branch-factor <n> | <round>=<n>[,...]"
+      inline_branch_factor
   let _inline_max_depth spec =
-    Int_arg_helper.parse spec ~update:inline_max_depth
-      ~help_text:"Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
+    Int_arg_helper.parse spec
+      "Syntax: -inline-max-depth <n> | <round>=<n>[,...]"
+      inline_max_depth
   let _no_unbox_free_vars_of_closures = clear unbox_free_vars_of_closures
   let _no_unbox_specialised_args = clear unbox_specialised_args
   let _o s = output_name := Some s
@@ -156,9 +167,13 @@ module Options = Main_args.Make_opttop_options (struct
   let _S = set keep_asm_file
   let _short_paths = clear real_paths
   let _stdin () = file_argument ""
+  let _unboxed_types = set unboxed_types
+  let _no_unboxed_types = clear unboxed_types
   let _unsafe = set fast
+  let _verbose = set verbose
   let _version () = print_version ()
   let _vnum () = print_version_num ()
+  let _no_version = set noversion
   let _w s = Warnings.parse_options false s
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings
@@ -187,6 +202,7 @@ module Options = Main_args.Make_opttop_options (struct
   let _safe_string = clear unsafe_string
   let _unsafe_string = set unsafe_string
   let _open s = open_modules := s :: !open_modules
+  let _plugin p = Compplugin.load p
 
   let anonymous = file_argument
 end);;

diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 7cce1987c30019389633124e78cd580f439d803b..a28ee990a6c8ad0ad2cd7ab502a63724417b7edd 100644 (file)
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -281,7 +281,7 @@ type 'a printer_type_new = Format.formatter -> 'a -> unit
 type 'a printer_type_old = 'a -> unit
 
 let printer_type ppf typename =
-  let (printer_type, _) =
+  let printer_type =
     try
       Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env
     with Not_found ->
@@ -289,7 +289,7 @@ let printer_type ppf typename =
       raise Exit in
   printer_type
 
-let match_simple_printer_type ppf desc printer_type =
+let match_simple_printer_type desc printer_type =
   Ctype.begin_def();
   let ty_arg = Ctype.newvar() in
   Ctype.unify !toplevel_env
@@ -299,7 +299,7 @@ let match_simple_printer_type ppf desc printer_type =
   Ctype.generalize ty_arg;
   (ty_arg, None)
 
-let match_generic_printer_type ppf desc path args printer_type =
+let match_generic_printer_type desc path args printer_type =
   Ctype.begin_def();
   let args = List.map (fun _ -> Ctype.newvar ()) args in
   let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in
@@ -324,15 +324,15 @@ let match_printer_type ppf desc =
   let printer_type_old = printer_type ppf "printer_type_old" in
   Ctype.init_def(Ident.current_time());
   try
-    (match_simple_printer_type ppf desc printer_type_new, false)
+    (match_simple_printer_type desc printer_type_new, false)
   with Ctype.Unify _ ->
     try
-      (match_simple_printer_type ppf desc printer_type_old, true)
+      (match_simple_printer_type desc printer_type_old, true)
     with Ctype.Unify _ as exn ->
       match extract_target_parameters desc.val_type with
       | None -> raise exn
       | Some (path, args) ->
-          (match_generic_printer_type ppf desc path args printer_type_new,
+          (match_generic_printer_type desc path args printer_type_new,
            false)
 
 let find_printer_type ppf lid =
@@ -358,7 +358,7 @@ let dir_install_printer ppf lid =
     | None ->
        let print_function =
          if is_old_style then
-           (fun formatter repr -> Obj.obj v (Obj.obj repr))
+           (fun _formatter repr -> Obj.obj v (Obj.obj repr))
          else
            (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
        install_printer path ty_arg print_function
@@ -367,7 +367,7 @@ let dir_install_printer ppf lid =
          | [] ->
             let print_function =
               if is_old_style then
-                (fun formatter repr -> Obj.obj v (Obj.obj repr))
+                (fun _formatter repr -> Obj.obj v (Obj.obj repr))
               else
                 (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
             Zero print_function
@@ -379,7 +379,7 @@ let dir_install_printer ppf lid =
 
 let dir_remove_printer ppf lid =
   try
-    let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
+    let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in
     begin try
       remove_printer path
     with Not_found ->
@@ -414,7 +414,7 @@ let dir_trace ppf lid =
     let (path, desc) = Env.lookup_value lid !toplevel_env in
     (* Check if this is a primitive *)
     match desc.val_kind with
-    | Val_prim p ->
+    | Val_prim _ ->
         fprintf ppf "%a is an external function and cannot be traced.@."
         Printtyp.longident lid
     | _ ->
@@ -449,7 +449,7 @@ let dir_trace ppf lid =
 
 let dir_untrace ppf lid =
   try
-    let (path, desc) = Env.lookup_value lid !toplevel_env in
+    let (path, _desc) = Env.lookup_value lid !toplevel_env in
     let rec remove = function
     | [] ->
         fprintf ppf "%a was not traced.@." Printtyp.longident lid;
@@ -530,7 +530,7 @@ let reg_show_prim name to_sig doc =
 let () =
   reg_show_prim "show_val"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_value env loc lid in
+       let _path, desc = Typetexp.find_value env loc lid in
        [ Sig_value (id, desc) ]
     )
     "Print the signature of the corresponding value."
@@ -538,7 +538,7 @@ let () =
 let () =
   reg_show_prim "show_type"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_type env loc lid in
+       let _path, desc = Typetexp.find_type env loc lid in
        [ Sig_type (id, desc, Trec_not) ]
     )
     "Print the signature of the corresponding type constructor."
@@ -569,16 +569,25 @@ let () =
 let () =
   reg_show_prim "show_module"
     (fun env loc id lid ->
-       let path, md = Typetexp.find_module env loc lid in
-       [ Sig_module (id, {md with md_type = trim_signature md.md_type},
-                     Trec_not) ]
+       let rec accum_aliases path acc =
+         let md = Env.find_module path env in
+         let acc =
+           Sig_module (id, {md with md_type = trim_signature md.md_type},
+                       Trec_not) :: acc in
+         match md.md_type with
+         | Mty_alias(_, path) -> accum_aliases path acc
+         | Mty_ident _ | Mty_signature _ | Mty_functor _ ->
+             List.rev acc
+       in
+       let path, _ = Typetexp.find_module env loc lid in
+       accum_aliases path []
     )
     "Print the signature of the corresponding module."
 
 let () =
   reg_show_prim "show_module_type"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_modtype env loc lid in
+       let _path, desc = Typetexp.find_modtype env loc lid in
        [ Sig_modtype (id, desc) ]
     )
     "Print the signature of the corresponding module type."
@@ -586,7 +595,7 @@ let () =
 let () =
   reg_show_prim "show_class"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_class env loc lid in
+       let _path, desc = Typetexp.find_class env loc lid in
        [ Sig_class (id, desc, Trec_not) ]
     )
     "Print the signature of the corresponding class."
@@ -594,7 +603,7 @@ let () =
 let () =
   reg_show_prim "show_class_type"
     (fun env loc id lid ->
-       let path, desc = Typetexp.find_class_type env loc lid in
+       let _path, desc = Typetexp.find_class_type env loc lid in
        [ Sig_class_type (id, desc, Trec_not) ]
     )
     "Print the signature of the corresponding class type."
@@ -740,9 +749,9 @@ let print_directive ppf (name, directive, doc) =
     | Directive_bool _ -> " <bool>"
     | Directive_ident _ -> " <ident>" in
   match doc with
-  | None -> printf "#%s%s@." name param
+  | None -> fprintf ppf "#%s%s@." name param
   | Some doc ->
-      printf "@[<hov 2>#%s%s@\n%a@]@."
+      fprintf ppf "@[<hov 2>#%s%s@\n%a@]@."
         name param
         Format.pp_print_text doc
 

diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 1e54ed7d065c493a6059223bfb67fdbdc3a68972..e832fde5776791c43b5c06abca728c188eb63cc1 100644 (file)
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -65,9 +65,9 @@ let rec eval_path = function
         with Not_found ->
           raise (Symtable.Error(Symtable.Undefined_global name))
       end
-  | Pdot(p, s, pos) ->
+  | Pdot(p, _s, pos) ->
       Obj.field (eval_path p) pos
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Toploop.eval_path"
 
 let eval_path env path =
@@ -158,7 +158,7 @@ let record_backtrace () =
 
 let load_lambda ppf lam =
   if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
-  let slam = Simplif.simplify_lambda lam in
+  let slam = Simplif.simplify_lambda "//toplevel//" lam in
   if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
   let (init_code, fun_code) = Bytegen.compile_phrase slam in
   if !Clflags.dump_instr then
@@ -334,7 +334,7 @@ let execute_phrase print_outcome ppf phr =
                        dir_name;
                false
              end
-          | Directive_int f, Pdir_int (n, Some _) ->
+          | Directive_int _, Pdir_int (_, Some _) ->
               fprintf ppf "Wrong integer literal for directive `%s'.@."
                 dir_name;
               false
@@ -352,19 +352,6 @@ let execute_phrase print_outcome ppf phr =
     Warnings.reset_fatal ();
     raise exn
 
-(* Temporary assignment to a reference *)
-
-let protect r newval body =
-  let oldval = !r in
-  try
-    r := newval;
-    let res = body() in
-    r := oldval;
-    res
-  with x ->
-    r := oldval;
-    raise x
-
 (* Read and execute commands from a file, or from stdin if [name] is "". *)
 
 let use_print_results = ref true
@@ -376,6 +363,9 @@ let preprocess_phrase ppf phr =
         let str =
           Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
         in
+        let str =
+          Pparse.ImplementationHooks.apply_hooks
+            { Misc.sourcefile = "//toplevel//" } str in
         Ptop_def str
     | phr -> phr
   in
@@ -398,9 +388,9 @@ let use_file ppf wrap_mod name =
     Warnings.reset_fatal ();
     Location.init lb filename;
     (* Skip initial #! line if any *)
-    Lexer.skip_sharp_bang lb;
+    Lexer.skip_hash_bang lb;
     let success =
-      protect Location.input_name filename (fun () ->
+      protect_refs [ R (Location.input_name, filename) ] (fun () ->
         try
           List.iter
             (fun ph ->
@@ -423,7 +413,7 @@ let mod_use_file ppf name = use_file ppf true name
 let use_file ppf name = use_file ppf false name
 
 let use_silently ppf name =
-  protect use_print_results false (fun () -> use_file ppf name)
+  protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
 
 (* Reading function for interactive use *)
 
@@ -508,7 +498,9 @@ let set_paths () =
      but keep the directories that user code linked in with ocamlmktop
      may have added to load_path. *)
   load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"];
-  load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path);
+  load_path := "" :: List.rev (!Compenv.last_include_dirs @
+                               !Clflags.include_dirs @
+                               !Compenv.first_include_dirs) @ !load_path;
   Dll.add_path !load_path
 
 let initialize_toplevel_env () =
@@ -520,7 +512,8 @@ exception PPerror
 
 let loop ppf =
   Location.formatter_for_warnings := ppf;
-  fprintf ppf "        OCaml version %s@.@." Config.version;
+  if not !Clflags.noversion then
+    fprintf ppf "        OCaml version %s@.@." Config.version;
   begin
     try initialize_toplevel_env ()
     with Env.Error _ | Typetexp.Error _ as exn ->
@@ -552,12 +545,15 @@ let loop ppf =
 
 (* Execute a script.  If [name] is "", read the script from stdin. *)
 
-let run_script ppf name args =
+let override_sys_argv args =
   let len = Array.length args in
-  if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";
+  if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
   Array.blit args 0 Sys.argv 0 len;
   Obj.truncate (Obj.repr Sys.argv) len;
-  Arg.current := 0;
+  Arg.current := 0
+
+let run_script ppf name args =
+  override_sys_argv args;
   Compmisc.init_path ~dir:(Filename.dirname name) true;
                    (* Note: would use [Filename.abspath] here, if we had it. *)
   begin

diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index ba2f0c6d9bf6244842361fced98cb60d85eeef0b..7a478b3c345833ecb4f7adf85e75f086c7603209 100644 (file)
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -145,3 +145,13 @@ val toplevel_startup_hook : (unit -> unit) ref
 (* Used by Trace module *)
 
 val may_trace : bool ref
+
+(* Misc *)
+
+val override_sys_argv : string array -> unit
+(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args]
+   and reset [Arg.current] to [0].
+
+   This is called by [run_script] so that [Sys.argv] represents
+   "script.ml args..." instead of the full command line:
+   "ocamlrun unix.cma ... script.ml args...". *)

diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 581abd436554598322049d840303b5ebf98d533c..16f0c76b8aa3900676a7a025d93c162cb7f2daa2 100644 (file)
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -25,7 +25,11 @@ let prepare ppf =
   Toploop.set_paths ();
   try
     let res =
-      List.for_all (Topdirs.load_file ppf) (List.rev !preload_objects) in
+      let objects =
+        List.rev (!preload_objects @ !first_objfiles)
+      in
+      List.for_all (Topdirs.load_file ppf) objects
+    in
     !Toploop.toplevel_startup_hook ();
     res
   with x ->
@@ -81,6 +85,7 @@ module Options = Main_args.Make_bytetop_options (struct
   let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
   let _open s = open_modules := s :: !open_modules
+  let _plugin p = Compplugin.load p
   let _ppx s = first_ppx := s :: !first_ppx
   let _principal = set principal
   let _no_principal = clear principal
@@ -93,10 +98,13 @@ module Options = Main_args.Make_bytetop_options (struct
   let _no_strict_sequence = clear strict_sequence
   let _strict_formats = set strict_formats
   let _no_strict_formats = clear strict_formats
+  let _unboxed_types = set unboxed_types
+  let _no_unboxed_types = clear unboxed_types
   let _unsafe = set fast
   let _unsafe_string = set unsafe_string
   let _version () = print_version ()
   let _vnum () = print_version_num ()
+  let _no_version = set noversion
   let _w s = Warnings.parse_options false s
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings

diff --git a/toplevel/trace.ml b/toplevel/trace.ml
index fbc03427672b80b3936b15b17e51fe77aad02efd..cc732a61a415cec00ec91f7abe1834dc7522d2b8 100644 (file)
--- a/toplevel/trace.ml
+++ b/toplevel/trace.ml
@@ -67,7 +67,7 @@ let rec instrument_result env name ppf clos_typ =
         match name with
         | Lident s -> Lident(s ^ "*")
         | Ldot(lid, s) -> Ldot(lid, s ^ "*")
-        | Lapply(l1, l2) -> fatal_error "Trace.instrument_result" in
+        | Lapply _ -> fatal_error "Trace.instrument_result" in
       let trace_res = instrument_result env starred_name ppf t2 in
       (fun clos_val ->
         Obj.repr (fun arg ->

diff --git a/typing/btype.ml b/typing/btype.ml
index 69c936470a30e3182cdf73c5f000ada18f7e8e53..686bfc442dcdd11e1ef397d3e2306b40fba61188 100644 (file)
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -352,7 +352,7 @@ let type_iterators =
     it.it_path ctd.clty_path
   and it_module_type it = function
       Mty_ident p
-    | Mty_alias p -> it.it_path p
+    | Mty_alias(_, p) -> it.it_path p
     | Mty_signature sg -> it.it_signature it sg
     | Mty_functor (_, mto, mt) ->
         may (it.it_module_type it) mto;
@@ -383,7 +383,7 @@ let type_iterators =
     | Tvariant row ->
         may (fun (p,_) -> it.it_path p) (row_repr row).row_name
     | _ -> ()
-  and it_path p = ()
+  and it_path _p = ()
   in
   { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
     it_type_kind; it_class_type; it_module_type;
@@ -436,12 +436,12 @@ let rec copy_type_desc ?(keep_names=false) f = function
   | Tobject(ty, {contents = Some (p, tl)})
                         -> Tobject (f ty, ref (Some(p, List.map f tl)))
   | Tobject (ty, _)     -> Tobject (f ty, ref None)
-  | Tvariant row        -> assert false (* too ambiguous *)
+  | Tvariant _          -> assert false (* too ambiguous *)
   | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *)
       Tfield (p, field_kind_repr k, f ty1, f ty2)
   | Tnil                -> Tnil
   | Tlink ty            -> copy_type_desc f ty.desc
-  | Tsubst ty           -> assert false
+  | Tsubst _            -> assert false
   | Tunivar _ as ty     -> ty (* always keep the name *)
   | Tpoly (ty, tyl)     ->
       let tyl = List.map (fun x -> norm_univar (f x)) tyl in
@@ -510,7 +510,7 @@ let rec unmark_type ty =
   end
 
 let unmark_iterators =
-  let it_type_expr it ty = unmark_type ty in
+  let it_type_expr _it ty = unmark_type ty in
   {type_iterators with it_type_expr}
 
 let unmark_type_decl decl =
@@ -523,7 +523,7 @@ let unmark_extension_constructor ext =
 
 let unmark_class_signature sign =
   unmark_type sign.csig_self;
-  Vars.iter (fun l (m, v, t) -> unmark_type t) sign.csig_vars
+  Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars
 
 let unmark_class_type cty =
   unmark_iterators.it_class_type unmark_iterators cty
@@ -542,7 +542,7 @@ let lte_public p1 p2 =  (* Private <= Public *)
 
 let rec find_expans priv p1 = function
     Mnil -> None
-  | Mcons (priv', p2, ty0, ty, _)
+  | Mcons (priv', p2, _ty0, ty, _)
     when lte_public priv priv' && Path.same p1 p2 -> Some ty
   | Mcons (_, _, _, _, rem)   -> find_expans priv p1 rem
   | Mlink {contents = rem} -> find_expans priv p1 rem
@@ -718,7 +718,7 @@ let rec rev_compress_log log r =
   | Change (_, next) ->
       rev_compress_log log next
 
-let undo_compress (changes, old) =
+let undo_compress (changes, _old) =
   match !changes with
     Unchanged
   | Invalid -> ()

diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml
index c37bb20e978ad5b38d5e3dfe3f2e28caf8d34c4c..67795219e65dbbf71744dd43cb9e4e11dcff458a 100644 (file)
--- a/typing/cmi_format.ml
+++ b/typing/cmi_format.ml
@@ -17,6 +17,7 @@ type pers_flags =
   | Rectypes
   | Deprecated of string
   | Opaque
+  | Unsafe_string
 
 type error =
     Not_an_interface of string

diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli
index 252f2f64bd0ba7d99b067cde56e184da70012f31..d36612b1e85738e9fe90a6a03f21d64f935e625b 100644 (file)
--- a/typing/cmi_format.mli
+++ b/typing/cmi_format.mli
@@ -17,6 +17,7 @@ type pers_flags =
   | Rectypes
   | Deprecated of string
   | Opaque
+  | Unsafe_string
 
 type cmi_infos = {
     cmi_name : string;

diff --git a/typing/ctype.ml b/typing/ctype.ml
index 75211e14ad00648f071422202bff2260542f80df..96dbbb2bf6c99df279a8d67c6bb1ee8dd7ace143 100644 (file)
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -284,9 +284,9 @@ let associate_fields fields1 fields2 =
         (List.rev p, List.rev s, (List.rev s') @ l')
     | ((n, k, t)::r, (n', k', t')::r') when n = n' ->
         associate ((n, k, t, k', t')::p) s s' (r, r')
-    | ((n, k, t)::r, ((n', k', t')::_ as l')) when n < n' ->
+    | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' ->
         associate p ((n, k, t)::s) s' (r, l')
-    | (((n, k, t)::r as l), (n', k', t')::r') (* when n > n' *) ->
+    | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) ->
         associate p s ((n', k', t')::s') (l, r')
   in
   associate [] [] [] (fields1, fields2)
@@ -345,7 +345,7 @@ let row_variable ty =
 
 let set_object_name id rv params ty =
   match (repr ty).desc with
-    Tobject (fi, nm) ->
+    Tobject (_fi, nm) ->
       set_name nm (Some (Path.Pident id, rv::params))
   | _ ->
       assert false
@@ -382,7 +382,7 @@ let rec signature_of_class_type =
   function
     Cty_constr (_, _, cty) -> signature_of_class_type cty
   | Cty_signature sign     -> sign
-  | Cty_arrow (_, ty, cty)   -> signature_of_class_type cty
+  | Cty_arrow (_, _, cty)   -> signature_of_class_type cty
 
 let self_type cty =
   repr (signature_of_class_type cty).csig_self
@@ -418,7 +418,7 @@ let merge_row_fields fi1 fi2 =
 
 let rec filter_row_fields erase = function
     [] -> []
-  | (l,f as p)::fi ->
+  | (_l,f as p)::fi ->
       let fi = filter_row_fields erase fi in
       match row_field_repr f with
         Rabsent -> fi
@@ -511,7 +511,7 @@ let closed_type_decl decl =
                 | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l
           )
           v
-    | Type_record(r, rep) ->
+    | Type_record(r, _rep) ->
         List.iter (fun l -> closed_type l.ld_type) r
     | Type_open -> ()
     end;
@@ -659,7 +659,7 @@ let rec generalize_spine ty =
   | _ -> ()
 
 let forward_try_expand_once = (* Forward declaration *)
-  ref (fun env ty -> raise Cannot_expand)
+  ref (fun _env _ty -> raise Cannot_expand)
 
 (*
    Lower the levels of a type (assume [level] is not
@@ -707,7 +707,7 @@ let rec update_level env level ty =
     | None -> ()
     end;
     match ty.desc with
-      Tconstr(p, tl, abbrev) when level < get_level env p ->
+      Tconstr(p, _tl, _abbrev) when level < get_level env p ->
         (* Try first to replace an abbreviation by its expansion. *)
         begin try
           (* if is_newtype env p then raise Cannot_expand; *)
@@ -724,14 +724,14 @@ let rec update_level env level ty =
         if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
         log_type ty; ty.desc <- Tpackage (p', nl, tl);
         update_level env level ty
-    | Tobject(_, ({contents=Some(p, tl)} as nm))
+    | Tobject(_, ({contents=Some(p, _tl)} as nm))
       when level < get_level env p ->
         set_name nm None;
         update_level env level ty
     | Tvariant row ->
         let row = row_repr row in
         begin match row.row_name with
-        | Some (p, tl) when level < get_level env p ->
+        | Some (p, _tl) when level < get_level env p ->
             log_type ty;
             ty.desc <- Tvariant {row with row_name = None}
         | _ -> ()
@@ -749,40 +749,36 @@ let rec update_level env level ty =
 
 (* Generalize and lower levels of contravariant branches simultaneously *)
 
-let generalize_contravariant env =
-  if !Clflags.principal then generalize_structure else update_level env
-
-let rec generalize_expansive env var_level ty =
+let rec generalize_expansive env var_level visited ty =
   let ty = repr ty in
-  if ty.level <> generic_level then begin
-    if ty.level > var_level then begin
-      set_level ty generic_level;
-      match ty.desc with
-        Tconstr (path, tyl, abbrev) ->
-          let variance =
-            try (Env.find_type path env).type_variance
-            with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in
-          abbrev := Mnil;
-          List.iter2
-            (fun v t ->
-              if Variance.(mem May_weak v)
-              then generalize_contravariant env var_level t
-              else generalize_expansive env var_level t)
-            variance tyl
-      | Tpackage (_, _, tyl) ->
-          List.iter (generalize_contravariant env var_level) tyl
-      | Tarrow (_, t1, t2, _) ->
-          generalize_contravariant env var_level t1;
-          generalize_expansive env var_level t2
-      | _ ->
-          iter_type_expr (generalize_expansive env var_level) ty
-    end
+  if ty.level = generic_level || ty.level <= var_level then () else
+  if not (Hashtbl.mem visited ty.id) then begin
+    Hashtbl.add visited ty.id ();
+    match ty.desc with
+      Tconstr (path, tyl, abbrev) ->
+        let variance =
+          try (Env.find_type path env).type_variance
+          with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in
+        abbrev := Mnil;
+        List.iter2
+          (fun v t ->
+            if Variance.(mem May_weak v)
+            then generalize_structure var_level t
+            else generalize_expansive env var_level visited t)
+          variance tyl
+    | Tpackage (_, _, tyl) ->
+        List.iter (generalize_structure var_level) tyl
+    | Tarrow (_, t1, t2, _) ->
+        generalize_structure var_level t1;
+        generalize_expansive env var_level visited t2
+    | _ ->
+        iter_type_expr (generalize_expansive env var_level visited) ty
   end
 
 let generalize_expansive env ty =
   simple_abbrevs := Mnil;
   try
-    generalize_expansive env !nongen_level ty
+    generalize_expansive env !nongen_level (Hashtbl.create 7) ty
   with Unify ([_, ty'] as tr) ->
     raise (Unify ((ty, ty') :: tr))
 
@@ -864,7 +860,7 @@ let compute_univars ty =
   let node_univars = TypeHash.create 17 in
   let rec add_univar univ inv =
     match inv.inv_type.desc with
-      Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> ()
+      Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> ()
     | _ ->
         try
           let univs = TypeHash.find node_univars inv.inv_type in
@@ -1025,7 +1021,7 @@ let rec copy ?env ?partial ?keep_names ty =
               (* Return a new copy *)
               Tvariant (copy_row copy true row keep more')
           end
-      | Tfield (p, k, ty1, ty2) ->
+      | Tfield (_p, k, _ty1, ty2) ->
           begin match field_kind_repr k with
             Fabsent  -> Tlink (copy ty2)
           | Fpresent -> copy_type_desc copy desc
@@ -1064,7 +1060,7 @@ let instance_def sch =
   cleanup_types ();
   ty
 
-let generic_instance ?partial env sch =
+let generic_instance env sch =
   let old = !current_level in
   current_level := generic_level;
   let ty = instance env sch in
@@ -1104,6 +1100,7 @@ let new_declaration newtype manifest =
     type_loc = Location.none;
     type_attributes = [];
     type_immediate = false;
+    type_unboxed = unboxed_false_default_false;
   }
 
 let instance_constructor ?in_pattern cstr =
@@ -1117,10 +1114,10 @@ let instance_constructor ?in_pattern cstr =
             {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
           | _ -> "$" ^ cstr.cstr_name
         in
-        let (id, new_env) =
-          Env.enter_type (get_new_abstract_name name) decl !env in
+        let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+        let new_env = Env.add_local_type path decl !env in
         env := new_env;
-        let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in
+        let to_unify = newty (Tconstr (path,[],ref Mnil)) in
         let tv = copy existential in
         assert (is_Tvar tv);
         link_type tv to_unify
@@ -1281,7 +1278,7 @@ let instance_label fixed lbl =
     match repr lbl.lbl_arg with
       {desc = Tpoly (ty, tl)} ->
         instance_poly fixed tl ty
-    | ty ->
+    | _ ->
         [], copy lbl.lbl_arg
   in
   cleanup_types ();
@@ -1290,7 +1287,7 @@ let instance_label fixed lbl =
 (**** Instantiation with parameter substitution ****)
 
 let unify' = (* Forward declaration *)
-  ref (fun env ty1 ty2 -> raise (Unify []))
+  ref (fun _env _ty1 _ty2 -> raise (Unify []))
 
 let subst env level priv abbrev ty params args body =
   if List.length params <> List.length args then raise (Unify []);
@@ -1387,32 +1384,35 @@ let expand_abbrev_gen kind find_type_expansion env ty =
               ()
             end;
           let ty' = repr ty' in
-          assert (ty != ty');
+          (* assert (ty != ty'); *) (* PR#7324 *)
           ty'
       | None ->
-          let (params, body, lv) =
-            try find_type_expansion path env with Not_found ->
-              raise Cannot_expand
-          in
-          (* prerr_endline
-            ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
-          let ty' = subst env level kind abbrev (Some ty) params args body in
-          (* Hack to name the variant type *)
-          begin match repr ty' with
-            {desc=Tvariant row} as ty when static_row row ->
-              ty.desc <- Tvariant { row with row_name = Some (path, args) }
-          | _ -> ()
-          end;
-          (* For gadts, remember type as non exportable *)
-          (* The ambiguous level registered for ty' should be the highest *)
-          if !trace_gadt_instances then begin
-            match max lv (Env.gadt_instance_level env ty) with
-              None -> ()
-            | Some lv ->
-                if level < lv then raise (Unify [(ty, newvar2 level)]);
-                Env.add_gadt_instances env lv [ty; ty']
-          end;
-          ty'
+          match find_type_expansion path env with
+          | exception Not_found ->
+            (* another way to expand is to normalize the path itself *)
+            let path' = Env.normalize_path None env path in
+            if Path.same path path' then raise Cannot_expand
+            else newty2 level (Tconstr (path', args, abbrev))
+          | (params, body, lv) ->
+            (* prerr_endline
+              ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
+            let ty' = subst env level kind abbrev (Some ty) params args body in
+            (* Hack to name the variant type *)
+            begin match repr ty' with
+              {desc=Tvariant row} as ty when static_row row ->
+                ty.desc <- Tvariant { row with row_name = Some (path, args) }
+            | _ -> ()
+            end;
+            (* For gadts, remember type as non exportable *)
+            (* The ambiguous level registered for ty' should be the highest *)
+            if !trace_gadt_instances then begin
+              match max lv (Env.gadt_instance_level env ty) with
+                None -> ()
+              | Some lv ->
+                  if level < lv then raise (Unify [(ty, newvar2 level)]);
+                  Env.add_gadt_instances env lv [ty; ty']
+            end;
+            ty'
       end
   | _ ->
       assert false
@@ -1439,7 +1439,7 @@ let safe_abbrev env ty =
 let try_expand_once env ty =
   let ty = repr ty in
   match ty.desc with
-    Tconstr (p, _, _) -> repr (expand_abbrev env ty)
+    Tconstr _ -> repr (expand_abbrev env ty)
   | _ -> raise Cannot_expand
 
 (* This one only raises Cannot_expand *)
@@ -1524,7 +1524,7 @@ let expand_head_opt env ty =
    respect the type constraints *)
 let enforce_constraints env ty =
   match ty with
-    {desc = Tconstr (path, args, abbrev); level = level} ->
+    {desc = Tconstr (path, args, _abbrev); level = level} ->
       begin try
         let decl = Env.find_type path env in
         ignore
@@ -1588,7 +1588,7 @@ let rec occur_rec env allow_recursive visited ty0 = function
   | ty ->
   if ty == ty0  then raise Occur;
   match ty.desc with
-    Tconstr(p, tl, abbrev) ->
+    Tconstr(p, _tl, _abbrev) ->
       if allow_recursive && is_contractive env p then () else
       begin try
         if TypeSet.mem ty visited then raise Occur;
@@ -1635,27 +1635,42 @@ let occur_in env ty0 t =
 (* PR#6405: not needed since we allow recursion and work on normalized types *)
 (* PR#6992: we actually need it for contractiveness *)
 (* This is a simplified version of occur, only for the rectypes case *)
-let rec local_non_recursive_abbrev visited env p ty =
+
+let rec local_non_recursive_abbrev strict visited env p ty =
+  (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*)
   let ty = repr ty in
   if not (List.memq ty visited) then begin
     match ty.desc with
-      Tconstr(p', args, abbrev) ->
+      Tconstr(p', args, _abbrev) ->
         if Path.same p p' then raise Occur;
-        if is_contractive env p' then () else
+        if not strict && is_contractive env p' then () else
         let visited = ty :: visited in
         begin try
-          List.iter (local_non_recursive_abbrev visited env p) args
-        with Occur -> try
-          local_non_recursive_abbrev visited env p
+          (* try expanding, since [p] could be hidden *)
+          local_non_recursive_abbrev strict visited env p
             (try_expand_head try_expand_once env ty)
         with Cannot_expand ->
-          raise Occur
+          let params =
+            try (Env.find_type p' env).type_params
+            with Not_found -> args
+          in
+          List.iter2
+            (fun tv ty ->
+              let strict = strict || not (is_Tvar (repr tv)) in
+              local_non_recursive_abbrev strict visited env p ty)
+            params args
         end
-    | _ -> ()
+    | _ ->
+        if strict then (* PR#7374 *)
+          let visited = ty :: visited in
+          iter_type_expr (local_non_recursive_abbrev true visited env p) ty
   end
 
 let local_non_recursive_abbrev env p ty =
-  try local_non_recursive_abbrev [] env p ty; true
+  try (* PR#7397: need to check trace_gadt_instances *)
+    wrap_trace_gadt_instances env
+      (local_non_recursive_abbrev false [] env p) ty;
+    true
   with Occur -> false
 
 
@@ -1826,9 +1841,6 @@ let mkvariant fields closed =
        {row_fields = fields; row_closed = closed; row_more = newvar();
         row_bound = (); row_fixed = false; row_name = None })
 
-(* force unification in Reither when one side has as non-conjunctive type *)
-let rigid_variants = ref false
-
 (**** Unification ****)
 
 (* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
@@ -1885,9 +1897,9 @@ let reify env t =
   let create_fresh_constr lev name =
     let decl = new_declaration (Some (newtype_level, newtype_level)) None in
     let name = match name with Some s -> "$'"^s | _ -> "$" in
-    let name = get_new_abstract_name name in
-    let (id, new_env) = Env.enter_type name decl !env in
-    let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil))  in
+    let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
+    let new_env = Env.add_local_type path decl !env in
+    let t = newty2 lev (Tconstr (path,[],ref Mnil))  in
     env := new_env;
     t
   in
@@ -1938,6 +1950,17 @@ let non_aliasable p decl =
   (* in_pervasives p ||  (subsumed by in_current_module) *)
   in_current_module p && decl.type_newtype_level = None
 
+let is_instantiable env p =
+  try
+    let decl = Env.find_type p env in
+    decl.type_kind = Type_abstract &&
+    decl.type_private = Public &&
+    decl.type_arity = 0 &&
+    decl.type_manifest = None &&
+    not (non_aliasable p decl)
+  with Not_found -> false
+
+
 (* PR#7113: -safe-string should be a global property *)
 let compatible_paths p1 p2 =
   let open Predef in
@@ -2035,11 +2058,13 @@ and mcomp_fields type_pairs env ty1 ty2 =
   let (fields2, rest2) = flatten_fields ty2 in
   let (fields1, rest1) = flatten_fields ty1 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  let has_present =
+    List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in
   mcomp type_pairs env rest1 rest2;
-  if miss1 <> []  && (object_row ty1).desc = Tnil
-  || miss2 <> []  && (object_row ty2).desc = Tnil then raise (Unify []);
+  if has_present miss1  && (object_row ty2).desc = Tnil
+  || has_present miss2  && (object_row ty1).desc = Tnil then raise (Unify []);
   List.iter
-    (function (n, k1, t1, k2, t2) ->
+    (function (_n, k1, t1, k2, t2) ->
        mcomp_kind k1 k2;
        mcomp type_pairs env t1 t2)
     pairs
@@ -2048,9 +2073,9 @@ and mcomp_kind k1 k2 =
   let k1 = field_kind_repr k1 in
   let k2 = field_kind_repr k2 in
   match k1, k2 with
-    (Fvar _, Fvar _)
-  | (Fpresent, Fpresent) -> ()
-  | _                    -> raise (Unify [])
+    (Fpresent, Fabsent)
+  | (Fabsent, Fpresent) -> raise (Unify [])
+  | _                   -> ()
 
 and mcomp_row type_pairs env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
@@ -2167,17 +2192,18 @@ let find_lowest_level ty =
 let find_newtype_level env path =
   try match (Env.find_type path env).type_newtype_level with
     Some x -> x
-  | None -> assert false
-  with Not_found -> assert false
+  | None -> raise Not_found
+  with Not_found -> let lev = Path.binding_time path in (lev, lev)
 
 let add_gadt_equation env source destination =
-  if local_non_recursive_abbrev !env (Path.Pident source) destination then
+  if local_non_recursive_abbrev !env source destination then begin
     let destination = duplicate_type destination in
-    let source_lev = find_newtype_level !env (Path.Pident source) in
+    let source_lev = find_newtype_level !env source in
     let decl = new_declaration (Some source_lev) (Some destination) in
     let newtype_level = get_newtype_level () in
     env := Env.add_local_constraint source decl newtype_level !env;
     cleanup_abbrev ()
+  end
 
 let unify_eq_set = TypePairs.create 11
 
@@ -2222,10 +2248,10 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 =
         nt2 :: complete (if n = n2 then nl else nl1) ntl'
     | n :: nl, _ ->
         try
-          let (_, decl) =
+          let path =
             Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env'
           in
-          match decl with
+          match Env.find_type path env' with
             {type_arity = 0; type_kind = Type_abstract;
              type_private = Public; type_manifest = Some t2} ->
                (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2
@@ -2249,7 +2275,19 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
   && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found
 
 
-let unify_eq env t1 t2 =
+(* force unification in Reither when one side has as non-conjunctive type *)
+let rigid_variants = ref false
+
+(* drop not force unification in Reither, even in fixed case
+   (not sound, only use it when checking exhaustiveness) *)
+let passive_variants = ref false
+let with_passive_variants f x =
+  if !passive_variants then f x else
+  match passive_variants := true; f x with
+  | r           -> passive_variants := false; r
+  | exception e -> passive_variants := false; raise e
+
+let unify_eq t1 t2 =
   t1 == t2 ||
   match !umode with
   | Expression -> false
@@ -2274,7 +2312,7 @@ let rec unify (env:Env.t ref) t1 t2 =
   if t1 == t2 then () else
   let t1 = repr t1 in
   let t2 = repr t2 in
-  if unify_eq !env t1 t2 then () else
+  if unify_eq t1 t2 then () else
   let reset_tracing = check_trace_gadt_instances !env in
 
   try
@@ -2331,7 +2369,7 @@ and unify2 env t1 t2 =
   let lv = min t1'.level t2'.level in
   update_level !env lv t2;
   update_level !env lv t1;
-  if unify_eq !env t1' t2' then () else
+  if unify_eq t1' t2' then () else
 
   let t1 = repr t1 and t2 = repr t2 in
   if !trace_gadt_instances then begin
@@ -2351,7 +2389,7 @@ and unify2 env t1 t2 =
       (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
     else (t1, t2)
   in
-  if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then
+  if unify_eq t1 t1' || not (unify_eq t2 t2') then
     unify3 env t1 t1' t2 t2'
   else
     try unify3 env t2 t2' t1 t1' with Unify trace ->
@@ -2423,24 +2461,24 @@ and unify3 env t1 t1' t2 t2' =
                       reify env t1; reify env t2
                   end)
               inj (List.combine tl1 tl2)
-      | (Tconstr ((Path.Pident p) as path,[],_),
-         Tconstr ((Path.Pident p') as path',[],_))
-        when is_newtype !env path && is_newtype !env path'
+      | (Tconstr (path,[],_),
+         Tconstr (path',[],_))
+        when is_instantiable !env path && is_instantiable !env path'
         && !generate_equations ->
           let source, destination =
             if find_newtype_level !env path > find_newtype_level !env path'
-            then  p,t2'
-            else  p',t1'
+            then  path , t2'
+            else  path', t1'
           in
           add_gadt_equation env source destination
-      | (Tconstr ((Path.Pident p) as path,[],_), _)
-        when is_newtype !env path && !generate_equations ->
+      | (Tconstr (path,[],_), _)
+        when is_instantiable !env path && !generate_equations ->
           reify env t2';
-          add_gadt_equation env p t2'
-      | (_, Tconstr ((Path.Pident p) as path,[],_))
-        when is_newtype !env path && !generate_equations ->
+          add_gadt_equation env path t2'
+      | (_, Tconstr (path,[],_))
+        when is_instantiable !env path && !generate_equations ->
           reify env t1';
-          add_gadt_equation env p t1'
+          add_gadt_equation env path t1'
       | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern ->
           reify env t1';
           reify env t2';
@@ -2573,7 +2611,7 @@ and unify_kind k1 k2 =
 and unify_row env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let rm1 = row_more row1 and rm2 = row_more row2 in
-  if unify_eq !env rm1 rm2 then () else
+  if unify_eq rm1 rm2 then () else
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   if r1 <> [] && r2 <> [] then begin
     let ht = Hashtbl.create (List.length r1) in
@@ -2665,6 +2703,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
   | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
       if e1 == e2 then () else
       let redo =
+        not !passive_variants &&
         (m1 || m2 || fixed1 || fixed2 ||
          !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
         begin match tl1 @ tl2 with [] -> false
@@ -2688,8 +2727,9 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
       and (tl2',tlu2) = split_univars tl2' in
       begin match tlu1, tlu2 with
         [], [] -> ()
-      | (tu1::tlu1), (tu2::_) ->
+      | (tu1::tlu1), _ :: _ ->
           (* Attempt to merge all the types containing univars *)
+          if not !passive_variants then
           List.iter (unify env tu1) (tlu1@tlu2)
       | (tu::_, []) | ([], tu::_) -> occur_univar !env tu
       end;
@@ -2747,8 +2787,10 @@ let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 =
 let unify_var env t1 t2 =
   let t1 = repr t1 and t2 = repr t2 in
   if t1 == t2 then () else
-  match t1.desc with
-    Tvar _ ->
+  match t1.desc, t2.desc with
+    Tvar _, Tconstr _ when deep_occur t1 t2 ->
+      unify (ref env) t1 t2
+  | Tvar _, _ ->
       let reset_tracing = check_trace_gadt_instances env in
       begin try
         occur env t1 t2;
@@ -2938,7 +2980,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
               end
           | (Tvariant row1, Tvariant row2) ->
               moregen_row inst_nongen type_pairs env row1 row2
-          | (Tobject (fi1, nm1), Tobject (fi2, nm2)) ->
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
               moregen_fields inst_nongen type_pairs env fi1 fi2
           | (Tfield _, Tfield _) ->           (* Actually unused *)
               moregen_fields inst_nongen type_pairs env t1' t2'
@@ -3015,7 +3057,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
   | _ -> raise (Unify [])
   end;
   List.iter
-    (fun (l,f1,f2) ->
+    (fun (_l,f1,f2) ->
       let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
       if f1 == f2 then () else
       match f1, f2 with
@@ -3204,7 +3246,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
               end
           | (Tvariant row1, Tvariant row2) ->
               eqtype_row rename type_pairs subst env row1 row2
-          | (Tobject (fi1, nm1), Tobject (fi2, nm2)) ->
+          | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) ->
               eqtype_fields rename type_pairs subst env fi1 fi2
           | (Tfield _, Tfield _) ->       (* Actually unused *)
               eqtype_fields rename type_pairs subst env t1' t2'
@@ -3353,19 +3395,19 @@ let rec moregen_clty trace type_pairs env cty1 cty2 =
     | Cty_signature sign1, Cty_signature sign2 ->
         let ty1 = object_fields (repr sign1.csig_self) in
         let ty2 = object_fields (repr sign2.csig_self) in
-        let (fields1, rest1) = flatten_fields ty1
-        and (fields2, rest2) = flatten_fields ty2 in
-        let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
         List.iter
-          (fun (lab, k1, t1, k2, t2) ->
+          (fun (lab, _k1, t1, _k2, t2) ->
             begin try moregen true type_pairs env t1 t2 with Unify trace ->
               raise (Failure [CM_Meth_type_mismatch
                                  (lab, env, expand_trace env trace)])
            end)
         pairs;
       Vars.iter
-        (fun lab (mut, v, ty) ->
-           let (mut', v', ty') = Vars.find lab sign1.csig_vars in
+        (fun lab (_mut, _v, ty) ->
+           let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in
            try moregen true type_pairs env ty' ty with Unify trace ->
              raise (Failure [CM_Val_type_mismatch
                                 (lab, env, expand_trace env trace)]))
@@ -3422,16 +3464,16 @@ let match_class_types ?(trace=true) env pat_sch subj_sch =
     moregen true type_pairs env rest1 rest2;
     let error =
       List.fold_right
-        (fun (lab, k1, t1, k2, t2) err ->
+        (fun (lab, k1, _t1, k2, _t2) err ->
            try moregen_kind k1 k2; err with
              Unify _ -> CM_Public_method lab::err)
         pairs error
     in
     let error =
       Vars.fold
-        (fun lab (mut, vr, ty) err ->
+        (fun lab (mut, vr, _ty) err ->
           try
-            let (mut', vr', ty') = Vars.find lab sign1.csig_vars in
+            let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
             if mut = Mutable && mut' <> Mutable then
               CM_Non_mutable_value lab::err
             else if vr = Concrete && vr' <> Concrete then
@@ -3488,11 +3530,11 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 =
     | Cty_signature sign1, Cty_signature sign2 ->
         let ty1 = object_fields (repr sign1.csig_self) in
         let ty2 = object_fields (repr sign2.csig_self) in
-        let (fields1, rest1) = flatten_fields ty1
-        and (fields2, rest2) = flatten_fields ty2 in
-        let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+        let (fields1, _rest1) = flatten_fields ty1
+        and (fields2, _rest2) = flatten_fields ty2 in
+        let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in
         List.iter
-          (fun (lab, k1, t1, k2, t2) ->
+          (fun (lab, _k1, t1, _k2, t2) ->
              begin try eqtype true type_pairs subst env t1 t2 with
                Unify trace ->
                  raise (Failure [CM_Meth_type_mismatch
@@ -3531,7 +3573,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
         let err =
           let k = field_kind_repr k in
           begin match k with
-            Fvar r -> err
+            Fvar _ -> err
           | _      -> CM_Hide_public lab::err
           end
         in
@@ -3547,7 +3589,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
   eqtype true type_pairs subst env rest1 rest2;
   let error =
     List.fold_right
-      (fun (lab, k1, t1, k2, t2) err ->
+      (fun (lab, k1, _t1, k2, _t2) err ->
         let k1 = field_kind_repr k1 in
         let k2 = field_kind_repr k2 in
         match k1, k2 with
@@ -3560,9 +3602,9 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
   in
   let error =
     Vars.fold
-      (fun lab (mut, vr, ty) err ->
+      (fun lab (mut, vr, _ty) err ->
          try
-           let (mut', vr', ty') = Vars.find lab sign1.csig_vars in
+           let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in
            if mut = Mutable && mut' <> Mutable then
              CM_Non_mutable_value lab::err
            else if vr = Concrete && vr' <> Concrete then
@@ -3646,16 +3688,18 @@ let rec filter_visited = function
 let memq_warn t visited =
   if List.memq t visited then (warn := true; true) else false
 
-let rec lid_of_path ?(sharp="") = function
+let rec lid_of_path ?(hash="") = function
     Path.Pident id ->
-      Longident.Lident (sharp ^ Ident.name id)
+      Longident.Lident (hash ^ Ident.name id)
   | Path.Pdot (p1, s, _) ->
-      Longident.Ldot (lid_of_path p1, sharp ^ s)
+      Longident.Ldot (lid_of_path p1, hash ^ s)
   | Path.Papply (p1, p2) ->
-      Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2)
+      Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2)
 
 let find_cltype_for_path env p =
-  let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in
+  let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in
+  let cl_abbr = Env.find_type cl_path env in
+
   match cl_abbr.type_manifest with
     Some ty ->
       begin match (repr ty).desc with
@@ -3737,7 +3781,7 @@ let rec build_subtype env visited loops posi level t =
         if c > Unchanged then (t'',c)
         else (t, Unchanged)
       end
-  | Tconstr(p, tl, abbrev) ->
+  | Tconstr(p, tl, _abbrev) ->
       (* Must check recursion on constructors, since we do not always
          expand them *)
       if memq_warn t visited then (t, Unchanged) else
@@ -3876,10 +3920,10 @@ let rec subtype_rec env trace t1 t2 cstrs =
         subtype_list env trace tl1 tl2 cstrs
     | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
         cstrs
-    | (Tconstr(p1, tl1, abbrev1), _)
+    | (Tconstr(p1, _tl1, _abbrev1), _)
       when generic_abbrev env p1 && safe_abbrev env t1 ->
         subtype_rec env trace (expand_abbrev env t1) t2 cstrs
-    | (_, Tconstr(p2, tl2, abbrev2))
+    | (_, Tconstr(p2, _tl2, _abbrev2))
       when generic_abbrev env p2 && safe_abbrev env t2 ->
         subtype_rec env trace t1 (expand_abbrev env t2) cstrs
     | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
@@ -3983,7 +4027,7 @@ and subtype_fields env trace ty1 ty2 cstrs =
      !univar_pairs) :: cstrs
   in
   List.fold_left
-    (fun cstrs (_, k1, t1, k2, t2) ->
+    (fun cstrs (_, _k1, t1, _k2, t2) ->
       (* Theses fields are always present *)
       subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
     cstrs pairs
@@ -4082,7 +4126,7 @@ let unalias ty =
 (* Return the arity (as for curried functions) of the given type. *)
 let rec arity ty =
   match (repr ty).desc with
-    Tarrow(_, t1, t2, _) -> 1 + arity t2
+    Tarrow(_, _t1, t2, _) -> 1 + arity t2
   | _ -> 0
 
 (* Check whether an abbreviation expands to itself. *)
@@ -4090,7 +4134,7 @@ let cyclic_abbrev env id ty =
   let rec check_cycle seen ty =
     let ty = repr ty in
     match ty.desc with
-      Tconstr (p, tl, abbrev) ->
+      Tconstr (p, _tl, _abbrev) ->
         p = Path.Pident id || List.memq ty seen ||
         begin try
           check_cycle (ty :: seen) (expand_abbrev_opt env ty)
@@ -4107,12 +4151,21 @@ exception Non_closed0
 let visited = ref TypeSet.empty
 
 let rec closed_schema_rec env ty =
-  let ty = expand_head env ty in
+  let ty = repr ty in
   if TypeSet.mem ty !visited then () else begin
     visited := TypeSet.add ty !visited;
     match ty.desc with
       Tvar _ when ty.level <> generic_level ->
         raise Non_closed0
+    | Tconstr _ ->
+        let old = !visited in
+        begin try iter_type_expr (closed_schema_rec env) ty
+        with Non_closed0 -> try
+          visited := old;
+          closed_schema_rec env (try_expand_head try_expand_safe env ty)
+        with Cannot_expand ->
+          raise Non_closed0
+        end
     | Tfield(_, kind, t1, t2) ->
         if field_kind_repr kind = Fpresent then
           closed_schema_rec env t1;
@@ -4225,7 +4278,7 @@ let rec nondep_type_rec env id ty =
     TypeHash.add nondep_hash ty ty';
     ty'.desc <-
       begin match ty.desc with
-      | Tconstr(p, tl, abbrev) ->
+      | Tconstr(p, tl, _abbrev) ->
           if Path.isfree id p then
             begin try
               Tlink (nondep_type_rec env id
@@ -4270,7 +4323,7 @@ let rec nondep_type_rec env id ty =
             let row =
               copy_row (nondep_type_rec env id) true row true more' in
             match row.row_name with
-              Some (p, tl) when Path.isfree id p ->
+              Some (p, _tl) when Path.isfree id p ->
                 Tvariant {row with row_name = None}
             | _ -> Tvariant row
           end
@@ -4330,6 +4383,7 @@ let nondep_type_decl env mid id is_covariant decl =
       type_loc = decl.type_loc;
       type_attributes = decl.type_attributes;
       type_immediate = decl.type_immediate;
+      type_unboxed = decl.type_unboxed;
     }
   with Not_found ->
     clear_hash ();
@@ -4436,7 +4490,7 @@ let rec collapse_conj env visited ty =
     Tvariant row ->
       let row = row_repr row in
       List.iter
-        (fun (l,fi) ->
+        (fun (_l,fi) ->
           match row_field_repr fi with
             Reither (c, t1::(_::_ as tl), m, e) ->
               List.iter (unify env t1) tl;
@@ -4463,7 +4517,7 @@ let () =
 
 let maybe_pointer_type env typ =
    match (repr typ).desc with
-  | Tconstr(p, args, abbrev) ->
+  | Tconstr(p, _args, _abbrev) ->
     begin try
       let type_decl = Env.find_type p env in
       not type_decl.type_immediate

diff --git a/typing/ctype.mli b/typing/ctype.mli
index 6da7fa867e523b0121089075998d6a6551545f30..f7a22e213e3feb5259f49ab691c416d5ea413e9d 100644 (file)
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -81,7 +81,7 @@ val set_object_name:
 val remove_object_name: type_expr -> unit
 val hide_private_methods: type_expr -> unit
 val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
-val lid_of_path: ?sharp:string -> Path.t -> Longident.t
+val lid_of_path: ?hash:string -> Path.t -> Longident.t
 
 val sort_row_fields: (label * row_field) list -> (label * row_field) list
 val merge_row_fields:
@@ -116,7 +116,7 @@ val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
            partial=true  -> newty2 ty.level Tvar for non generic subterms *)
 val instance_def: type_expr -> type_expr
         (* use defaults *)
-val generic_instance: ?partial:bool -> Env.t -> type_expr -> type_expr
+val generic_instance: Env.t -> type_expr -> type_expr
         (* Same as instance, but new nodes at generic_level *)
 val instance_list: Env.t -> type_expr list -> type_expr list
         (* Take an instance of a list of type schemes *)
@@ -170,6 +170,8 @@ val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
 val unify_var: Env.t -> type_expr -> type_expr -> unit
         (* Same as [unify], but allow free univars when first type
            is a variable. *)
+val with_passive_variants: ('a -> 'b) -> ('a -> 'b)
+        (* Call [f] in passive_variants mode, for exhaustiveness check. *)
 val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr
         (* A special case of unification (with l:'a -> 'b). *)
 val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr

diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 1645dd9eb8b82bf51be96d61b477dfe65b036094..5c46ae156bb01b4153f9ab14103c6695451d941b 100644 (file)
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -49,7 +49,7 @@ let free_vars ?(param=false) ty =
 
 let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
 
-let constructor_args cd_args cd_res path rep =
+let constructor_existentials cd_args cd_res =
   let tyl =
     match cd_args with
     | Cstr_tuple l -> l
@@ -63,23 +63,33 @@ let constructor_args cd_args cd_res path rep =
         let res_vars = free_vars type_ret in
         TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
   in
+  (tyl, existentials)
+
+let constructor_args priv cd_args cd_res path rep =
+  let tyl, existentials = constructor_existentials cd_args cd_res in
   match cd_args with
   | Cstr_tuple l -> existentials, l, None
   | Cstr_record lbls ->
       let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
       let type_params = TypeSet.elements arg_vars_set in
+      let type_unboxed =
+        match rep with
+        | Record_unboxed _ -> unboxed_true_default_false
+        | _ -> unboxed_false_default_false
+      in
       let tdecl =
         {
           type_params;
           type_arity = List.length type_params;
           type_kind = Type_record (lbls, rep);
-          type_private = Public;
+          type_private = priv;
           type_manifest = None;
           type_variance = List.map (fun _ -> Variance.full) type_params;
           type_newtype_level = None;
           type_loc = Location.none;
           type_attributes = [];
           type_immediate = false;
+          type_unboxed;
         }
       in
       existentials,
@@ -104,16 +114,22 @@ let constructor_descrs ty_path decl cstrs =
         in
         let (tag, descr_rem) =
           match cd_args with
-            Cstr_tuple [] -> (Cstr_constant idx_const,
+          | _ when decl.type_unboxed.unboxed ->
+            assert (rem = []);
+            (Cstr_unboxed, [])
+          | Cstr_tuple [] -> (Cstr_constant idx_const,
                    describe_constructors (idx_const+1) idx_nonconst rem)
           | _  -> (Cstr_block idx_nonconst,
                    describe_constructors idx_const (idx_nonconst+1) rem) in
-
         let cstr_name = Ident.name cd_id in
         let existentials, cstr_args, cstr_inlined =
-          constructor_args cd_args cd_res
-            (Path.Pdot (ty_path, cstr_name, Path.nopos))
-            (Record_inlined idx_nonconst)
+          let representation =
+            if decl.type_unboxed.unboxed
+            then Record_unboxed true
+            else Record_inlined idx_nonconst
+          in
+          constructor_args decl.type_private cd_args cd_res
+            (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation
         in
         let cstr =
           { cstr_name;
@@ -141,7 +157,7 @@ let extension_descr path_ext ext =
       | None -> newgenconstr ext.ext_type_path ext.ext_type_params
   in
   let existentials, cstr_args, cstr_inlined =
-    constructor_args ext.ext_args ext.ext_ret_type
+    constructor_args ext.ext_private ext.ext_args ext.ext_ret_type
       path_ext Record_extension
   in
     { cstr_name = Path.last path_ext;
@@ -201,7 +217,7 @@ let rec find_constr tag num_const num_nonconst = function
       then c
       else find_constr tag (num_const + 1) num_nonconst rem
   | c :: rem ->
-      if tag = Cstr_block num_nonconst
+      if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
       then c
       else find_constr tag num_const (num_nonconst + 1) rem
 

diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index de8a8c2858882b86d5679b74a454415e68fb42ad..8a85282add36d406531c0c256e2507df847d47c9 100644 (file)
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -34,3 +34,11 @@ exception Constr_not_found
 val find_constr_by_tag:
   constructor_tag -> constructor_declaration list ->
     constructor_declaration
+
+val constructor_existentials :
+    constructor_arguments -> type_expr option -> type_expr list * type_expr list
+(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and
+    returns:
+    - the types of the constructor's arguments
+    - the existential variables introduced by the constructor
+ *)

diff --git a/typing/env.ml b/typing/env.ml
index 20e7a7ce2b1f2e7e08db9f9831ac38ae620f2d32..7a0beff0b0af8a55dd354040116439779d87e2df 100644 (file)
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -35,6 +35,7 @@ let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t =
        cf Includemod.value_descriptions). *)
 
 let type_declarations = Hashtbl.create 16
+let module_declarations = Hashtbl.create 16
 
 type constructor_usage = Positive | Pattern | Privatize
 type constructor_usages =
@@ -60,6 +61,7 @@ type error =
   | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
+  | Depend_on_unsafe_string_unit of string * string
   | Missing_module of Location.t * Path.t * Path.t
   | Illegal_value_name of Location.t * string
 
@@ -104,6 +106,7 @@ end  = struct
 
 end
 
+module PathMap = Map.Make(Path)
 
 type summary =
     Env_empty
@@ -116,6 +119,7 @@ type summary =
   | Env_cltype of summary * Ident.t * class_type_declaration
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration PathMap.t
 
 module EnvTbl =
   struct
@@ -178,7 +182,7 @@ type t = {
   cltypes: (Path.t * class_type_declaration) EnvTbl.t;
   functor_args: unit Ident.tbl;
   summary: summary;
-  local_constraints: bool;
+  local_constraints: type_declaration PathMap.t;
   gadt_instances: (int * TypeSet.t ref) list;
   flags: int;
 }
@@ -186,6 +190,7 @@ type t = {
 and module_components =
   {
     deprecated: string option;
+    loc: Location.t;
     comps: (t * Subst.t * Path.t * Types.module_type, module_components_repr)
            EnvLazy.t;
   }
@@ -216,6 +221,12 @@ and functor_components = {
   fcomp_subst_cache: (Path.t, module_type) Hashtbl.t
 }
 
+let copy_local ~from env =
+  { env with
+    local_constraints = from.local_constraints;
+    gadt_instances = from.gadt_instances;
+    flags = from.flags }
+
 let same_constr = ref (fun _ _ _ -> assert false)
 
 (* Helper to decide whether to report an identifier shadowing
@@ -251,7 +262,7 @@ let empty = {
   modules = EnvTbl.empty; modtypes = EnvTbl.empty;
   components = EnvTbl.empty; classes = EnvTbl.empty;
   cltypes = EnvTbl.empty;
-  summary = Env_empty; local_constraints = false; gadt_instances = [];
+  summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = [];
   flags = 0;
   functor_args = Ident.empty;
  }
@@ -297,23 +308,24 @@ let diff env1 env2 =
 (* Forward declarations *)
 
 let components_of_module' =
-  ref ((fun ~deprecated env sub path mty -> assert false) :
-         deprecated:string option -> t -> Subst.t -> Path.t -> module_type ->
+  ref ((fun ~deprecated:_ ~loc:__env _sub _path _mty -> assert false) :
+         deprecated:string option -> loc:Location.t -> t -> Subst.t ->
+       Path.t -> module_type ->
        module_components)
 let components_of_module_maker' =
-  ref ((fun (env, sub, path, mty) -> assert false) :
+  ref ((fun (_env, _sub, _path, _mty) -> assert false) :
           t * Subst.t * Path.t * module_type -> module_components_repr)
 let components_of_functor_appl' =
-  ref ((fun f env p1 p2 -> assert false) :
+  ref ((fun _f _env _p1 _p2 -> assert false) :
           functor_components -> t -> Path.t -> Path.t -> module_components)
 let check_modtype_inclusion =
   (* to be filled with Includemod.check_modtype_inclusion *)
-  ref ((fun env mty1 path1 mty2 -> assert false) :
+  ref ((fun _env _mty1 _path1 _mty2 -> assert false) :
           t -> module_type -> Path.t -> module_type -> unit)
 let strengthen =
   (* to be filled with Mtype.strengthen *)
-  ref ((fun env mty path -> assert false) :
-         t -> module_type -> Path.t -> module_type)
+  ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
+         aliasable:bool -> t -> module_type -> Path.t -> module_type)
 
 let md md_type =
   {md_type; md_attributes=[]; md_loc=Location.none}
@@ -384,14 +396,25 @@ let save_pers_struct crc ps =
     (function
         | Rectypes -> ()
         | Deprecated _ -> ()
+        | Unsafe_string -> ()
         | Opaque -> add_imported_opaque modname)
     ps.ps_flags;
   Consistbl.set crc_units modname crc ps.ps_filename;
   add_import modname
 
-let read_pers_struct check modname filename =
-  add_import modname;
-  let cmi = read_cmi filename in
+module Persistent_signature = struct
+  type t =
+    { filename : string;
+      cmi : Cmi_format.cmi_infos }
+
+  let load = ref (fun ~unit_name ->
+    match find_in_path_uncap !load_path (unit_name ^ ".cmi") with
+    | filename -> Some { filename; cmi = read_cmi filename }
+    | exception Not_found -> None)
+end
+
+let acknowledge_pers_struct check modname
+      { Persistent_signature.filename; cmi } =
   let name = cmi.cmi_name in
   let sign = cmi.cmi_sign in
   let crcs = cmi.cmi_crcs in
@@ -401,7 +424,8 @@ let read_pers_struct check modname filename =
       flags
   in
   let comps =
-      !components_of_module' ~deprecated empty Subst.identity
+      !components_of_module' ~deprecated ~loc:Location.none
+        empty Subst.identity
                              (Pident(Ident.create_persistent name))
                              (Mty_signature sign)
   in
@@ -414,11 +438,15 @@ let read_pers_struct check modname filename =
            } in
   if ps.ps_name <> modname then
     error (Illegal_renaming(modname, ps.ps_name, filename));
+
   List.iter
     (function
         | Rectypes ->
             if not !Clflags.recursive_types then
               error (Need_recursive_types(ps.ps_name, !current_unit))
+        | Unsafe_string ->
+            if Config.safe_string then
+              error (Depend_on_unsafe_string_unit (ps.ps_name, !current_unit));
         | Deprecated _ -> ()
         | Opaque -> add_imported_opaque modname)
     ps.ps_flags;
@@ -426,20 +454,31 @@ let read_pers_struct check modname filename =
   Hashtbl.add persistent_structures modname (Some ps);
   ps
 
+let read_pers_struct check modname filename =
+  add_import modname;
+  let cmi = read_cmi filename in
+  acknowledge_pers_struct check modname
+    { Persistent_signature.filename; cmi }
+
+let can_load_cmis = ref true
+let without_cmis f x =
+  Misc.(protect_refs [R (can_load_cmis, false)] (fun () -> f x))
+
 let find_pers_struct check name =
   if name = "*predef*" then raise Not_found;
   match Hashtbl.find persistent_structures name with
   | Some ps -> ps
   | None -> raise Not_found
-  | exception Not_found ->
-      let filename =
-        try
-          find_in_path_uncap !load_path (name ^ ".cmi")
-        with Not_found ->
+  | exception Not_found when !can_load_cmis ->
+      let ps =
+        match !Persistent_signature.load ~unit_name:name with
+        | Some ps -> ps
+        | None ->
           Hashtbl.add persistent_structures name None;
           raise Not_found
       in
-      read_pers_struct check name filename
+      add_import name;
+      acknowledge_pers_struct check name ps
 
 (* Emits a warning if there is no valid cmi for name *)
 let check_pers_struct name =
@@ -466,6 +505,9 @@ let check_pers_struct name =
             Format.sprintf
               "%s uses recursive types"
               name
+        | Depend_on_unsafe_string_unit (name, _) ->
+            Printf.sprintf "%s uses -unsafe-string"
+              name
         | Missing_module _ -> assert false
         | Illegal_value_name _ -> assert false
       in
@@ -495,6 +537,7 @@ let reset_cache () =
   clear_imports ();
   Hashtbl.clear value_declarations;
   Hashtbl.clear type_declarations;
+  Hashtbl.clear module_declarations;
   Hashtbl.clear used_constructors;
   Hashtbl.clear prefixed_sg
 
@@ -508,6 +551,7 @@ let reset_cache_toplevel () =
   List.iter (Hashtbl.remove persistent_structures) l;
   Hashtbl.clear value_declarations;
   Hashtbl.clear type_declarations;
+  Hashtbl.clear module_declarations;
   Hashtbl.clear used_constructors;
   Hashtbl.clear prefixed_sg
 
@@ -524,42 +568,42 @@ let rec find_module_descr path env =
   match path with
     Pident id ->
       begin try
-        let (p, desc) = EnvTbl.find_same id env.components
+        let (_p, desc) = EnvTbl.find_same id env.components
         in desc
       with Not_found ->
         if Ident.persistent id && not (Ident.name id = !current_unit)
         then (find_pers_struct (Ident.name id)).ps_comps
         else raise Not_found
       end
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (descr, pos) = Tbl.find s c.comp_components in
+          let (descr, _pos) = Tbl.find s c.comp_components in
           descr
-      | Functor_comps f ->
+      | Functor_comps _ ->
          raise Not_found
       end
   | Papply(p1, p2) ->
       begin match get_components (find_module_descr p1 env) with
         Functor_comps f ->
           !components_of_functor_appl' f env p1 p2
-      | Structure_comps c ->
+      | Structure_comps _ ->
           raise Not_found
       end
 
 let find proj1 proj2 path env =
   match path with
     Pident id ->
-      let (p, data) = EnvTbl.find_same id (proj1 env)
+      let (_p, data) = EnvTbl.find_same id (proj1 env)
       in data
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (data, pos) = Tbl.find s (proj2 c) in data
-      | Functor_comps f ->
+          let (data, _pos) = Tbl.find s (proj2 c) in data
+      | Functor_comps _ ->
           raise Not_found
       end
-  | Papply(p1, p2) ->
+  | Papply _ ->
       raise Not_found
 
 let find_value =
@@ -581,7 +625,9 @@ let type_of_cstr path = function
 
 let find_type_full path env =
   match Path.constructor_typath path with
-  | Regular p -> find_type_full p env
+  | Regular p ->
+      (try (PathMap.find p env.local_constraints, ([], []))
+       with Not_found -> find_type_full p env)
   | Cstr (ty_path, s) ->
       let (_, (cstrs, _)) =
         try find_type_full ty_path env
@@ -627,7 +673,7 @@ let find_module ~alias path env =
   match path with
     Pident id ->
       begin try
-        let (p, data) = EnvTbl.find_same id env.modules
+        let (_p, data) = EnvTbl.find_same id env.modules
         in data
       with Not_found ->
         if Ident.persistent id && not (Ident.name id = !current_unit) then
@@ -635,12 +681,12 @@ let find_module ~alias path env =
           md (Mty_signature(Lazy.force ps.ps_sig))
         else raise Not_found
       end
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (data, pos) = Tbl.find s c.comp_modules in
+          let (data, _pos) = Tbl.find s c.comp_modules in
           md (EnvLazy.force subst_modtype_maker data)
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
   | Papply(p1, p2) ->
@@ -648,7 +694,7 @@ let find_module ~alias path env =
       begin match get_components desc1 with
         Functor_comps f ->
           md begin match f.fcomp_res with
-          | Mty_alias p as mty-> mty
+          | Mty_alias _ as mty -> mty
           | mty ->
               if alias then mty else
               try
@@ -661,7 +707,7 @@ let find_module ~alias path env =
                 Hashtbl.add f.fcomp_subst_cache p2 mty;
                 mty
           end
-      | Structure_comps c ->
+      | Structure_comps _ ->
           raise Not_found
       end
 
@@ -683,7 +729,7 @@ let rec normalize_path lax env path =
     | _ -> path
   in
   try match find_module ~alias:true path env with
-    {md_type=Mty_alias path1} ->
+    {md_type=Mty_alias(_, path1)} ->
       let path' = normalize_path lax env path1 in
       if lax || !Clflags.transparent_modules then path' else
       let id = Path.head path in
@@ -702,6 +748,16 @@ let normalize_path oloc env path =
     | Some loc ->
         raise (Error(Missing_module(loc, path, normalize_path true env path)))
 
+let normalize_path_prefix oloc env path =
+  match path with
+    Pdot(p, s, pos) ->
+      Pdot(normalize_path oloc env p, s, pos)
+  | Pident _ ->
+      path
+  | Papply _ ->
+      assert false
+
+
 let find_module = find_module ~alias:false
 
 (* Find the manifest type associated to a type when appropriate:
@@ -718,13 +774,7 @@ let find_type_expansion path env =
      private row are still considered unknown to the type system.
      Hence, this case is caught by the following clause that also handles
      purely abstract data types without manifest type definition. *)
-  | _ ->
-      (* another way to expand is to normalize the path itself *)
-      let path' = normalize_path None env path in
-      if Path.same path path' then raise Not_found else
-      (decl.type_params,
-       newgenty (Tconstr (path', decl.type_params, ref Mnil)),
-       may_map snd decl.type_newtype_level)
+  | _ -> raise Not_found
 
 (* Find the manifest type information associated to a type, i.e.
    the necessary information for the compiler's type-based optimisations.
@@ -736,12 +786,7 @@ let find_type_expansion_opt path env =
   (* The manifest type of Private abstract data types can still get
      an approximation using their manifest type. *)
   | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
-  | _ ->
-      let path' = normalize_path None env path in
-      if Path.same path path' then raise Not_found else
-      (decl.type_params,
-       newgenty (Tconstr (path', decl.type_params, ref Mnil)),
-       may_map snd decl.type_newtype_level)
+  | _ -> raise Not_found
 
 let find_modtype_expansion path env =
   match (find_modtype path env).mtd_type with
@@ -754,7 +799,7 @@ let rec is_functor_arg path env =
       begin try Ident.find_same id env.functor_args; true
       with Not_found -> false
       end
-  | Pdot (p, s, _) -> is_functor_arg p env
+  | Pdot (p, _s, _) -> is_functor_arg p env
   | Papply _ -> true
 
 (* Lookup by name *)
@@ -770,6 +815,11 @@ let report_deprecated ?loc p deprecated =
                                 (Path.name p) txt))
   | _ -> ()
 
+let mark_module_used env name loc =
+  if not (is_implicit_coercion env) then
+    try Hashtbl.find module_declarations (name, loc) ()
+    with Not_found -> ()
+
 let rec lookup_module_descr_aux ?loc lid env =
   match lid with
     Lident s ->
@@ -786,7 +836,7 @@ let rec lookup_module_descr_aux ?loc lid env =
         Structure_comps c ->
           let (descr, pos) = Tbl.find s c.comp_components in
           (Pdot(p, s, pos), descr)
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
   | Lapply(l1, l2) ->
@@ -797,12 +847,17 @@ let rec lookup_module_descr_aux ?loc lid env =
         Functor_comps f ->
           Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
           (Papply(p1, p2), !components_of_functor_appl' f env p1 p2)
-      | Structure_comps c ->
+      | Structure_comps _ ->
           raise Not_found
       end
 
 and lookup_module_descr ?loc lid env =
   let (p, comps) as res = lookup_module_descr_aux ?loc lid env in
+  mark_module_used env (Path.last p) comps.loc;
+(*
+  Format.printf "USE module %s at %a@." (Path.last p)
+    Location.print comps.loc;
+*)
   report_deprecated ?loc p comps.deprecated;
   res
 
@@ -810,7 +865,10 @@ and lookup_module ~load ?loc lid env : Path.t =
   match lid with
     Lident s ->
       begin try
-        let (p, {md_type; md_attributes}) = EnvTbl.find_name s env.modules in
+        let (p, {md_type; md_attributes; md_loc}) =
+          EnvTbl.find_name s env.modules
+        in
+        mark_module_used env s md_loc;
         begin match md_type with
         | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
           (* see #5965 *)
@@ -834,12 +892,13 @@ and lookup_module ~load ?loc lid env : Path.t =
       let (p, descr) = lookup_module_descr ?loc l env in
       begin match get_components descr with
         Structure_comps c ->
-          let (data, pos) = Tbl.find s c.comp_modules in
+          let (_data, pos) = Tbl.find s c.comp_modules in
           let (comps, _) = Tbl.find s c.comp_components in
+          mark_module_used env s comps.loc;
           let p = Pdot(p, s, pos) in
           report_deprecated ?loc p comps.deprecated;
           p
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
   | Lapply(l1, l2) ->
@@ -851,7 +910,7 @@ and lookup_module ~load ?loc lid env : Path.t =
         Functor_comps f ->
           Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
           p
-      | Structure_comps c ->
+      | Structure_comps _ ->
           raise Not_found
       end
 
@@ -865,10 +924,10 @@ let lookup proj1 proj2 ?loc lid env =
         Structure_comps c ->
           let (data, pos) = Tbl.find s (proj2 c) in
           (Pdot(p, s, pos), data)
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
-  | Lapply(l1, l2) ->
+  | Lapply _ ->
       raise Not_found
 
 let lookup_all_simple proj1 proj2 shadow ?loc lid env =
@@ -880,33 +939,33 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env =
         | [] -> []
         | ((x, f) :: xs) ->
             (x, f) ::
-              (do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs))
+              (do_shadow (List.filter (fun (y, _) -> not (shadow x y)) xs))
       in
         do_shadow xl
   | Ldot(l, s) ->
-      let (p, desc) = lookup_module_descr ?loc l env in
+      let (_p, desc) = lookup_module_descr ?loc l env in
       begin match get_components desc with
         Structure_comps c ->
           let comps =
             try Tbl.find s (proj2 c) with Not_found -> []
           in
           List.map
-            (fun (data, pos) -> (data, (fun () -> ())))
+            (fun (data, _pos) -> (data, (fun () -> ())))
             comps
-      | Functor_comps f ->
+      | Functor_comps _ ->
           raise Not_found
       end
-  | Lapply(l1, l2) ->
+  | Lapply _ ->
       raise Not_found
 
-let has_local_constraints env = env.local_constraints
+let has_local_constraints env = not (PathMap.is_empty env.local_constraints)
 
 let cstr_shadow cstr1 cstr2 =
   match cstr1.cstr_tag, cstr2.cstr_tag with
   | Cstr_extension _, Cstr_extension _ -> true
   | _ -> false
 
-let lbl_shadow lbl1 lbl2 = false
+let lbl_shadow _lbl1 _lbl2 = false
 
 let lookup_value =
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
@@ -989,7 +1048,7 @@ let lookup_value ?loc lid env =
 let lookup_type ?loc lid env =
   let (path, (decl, _)) = lookup_type ?loc lid env in
   mark_type_used env (Longident.last lid) decl;
-  (path, decl)
+  path
 
 let mark_type_path env path =
   try
@@ -1082,10 +1141,10 @@ let iter_env_cont = ref []
 
 let rec scrape_alias_for_visit env mty =
   match mty with
-  | Mty_alias (Pident id)
+  | Mty_alias(_, Pident id)
     when Ident.persistent id
       && not (Hashtbl.mem persistent_structures (Ident.name id)) -> false
-  | Mty_alias path -> (* PR#6600: find_module may raise Not_found *)
+  | Mty_alias(_, path) -> (* PR#6600: find_module may raise Not_found *)
       begin try scrape_alias_for_visit env (find_module path env).md_type
       with Not_found -> false
       end
@@ -1098,7 +1157,7 @@ let iter_env proj1 proj2 f env () =
       let visit =
         match EnvLazy.get_arg mcomps.comps with
         | None -> true
-        | Some (env, sub, path, mty) -> scrape_alias_for_visit env mty
+        | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty
       in
       if not visit then () else
       match get_components mcomps with
@@ -1233,7 +1292,7 @@ let rec scrape_alias env ?path mty =
       with Not_found ->
         mty
       end
-  | Mty_alias path, _ ->
+  | Mty_alias(_, path), _ ->
       begin try
         scrape_alias env (find_module path env).md_type ~path
       with Not_found ->
@@ -1242,7 +1301,7 @@ let rec scrape_alias env ?path mty =
         mty
       end
   | mty, Some path ->
-      !strengthen env mty path
+      !strengthen ~aliasable:true env mty path
   | _ -> mty
 
 let scrape_alias env mty = scrape_alias env mty
@@ -1257,35 +1316,35 @@ let rec prefix_idents root pos sub = function
       let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in
       let (pl, final_sub) = prefix_idents root nextpos sub rem in
       (p::pl, final_sub)
-  | Sig_type(id, decl, _) :: rem ->
+  | Sig_type(id, _, _) :: rem ->
       let p = Pdot(root, Ident.name id, nopos) in
       let (pl, final_sub) =
         prefix_idents root pos (Subst.add_type id p sub) rem in
       (p::pl, final_sub)
-  | Sig_typext(id, ext, _) :: rem ->
+  | Sig_typext(id, _, _) :: rem ->
       let p = Pdot(root, Ident.name id, pos) in
       (* we extend the substitution in case of an inlined record *)
       let (pl, final_sub) =
         prefix_idents root (pos+1) (Subst.add_type id p sub) rem in
       (p::pl, final_sub)
-  | Sig_module(id, mty, _) :: rem ->
+  | Sig_module(id, _, _) :: rem ->
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) =
         prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
       (p::pl, final_sub)
-  | Sig_modtype(id, decl) :: rem ->
+  | Sig_modtype(id, _) :: rem ->
       let p = Pdot(root, Ident.name id, nopos) in
       let (pl, final_sub) =
         prefix_idents root pos
                       (Subst.add_modtype id (Mty_ident p) sub) rem in
       (p::pl, final_sub)
-  | Sig_class(id, decl, _) :: rem ->
+  | Sig_class(id, _, _) :: rem ->
       (* pretend this is a type, cf. PR#6650 *)
       let p = Pdot(root, Ident.name id, pos) in
       let (pl, final_sub) =
         prefix_idents root (pos + 1) (Subst.add_type id p sub) rem in
       (p::pl, final_sub)
-  | Sig_class_type(id, decl, _) :: rem ->
+  | Sig_class_type(id, _, _) :: rem ->
       let p = Pdot(root, Ident.name id, nopos) in
       let (pl, final_sub) =
         prefix_idents root pos (Subst.add_type id p sub) rem in
@@ -1318,7 +1377,7 @@ let prefix_idents_and_subst root sub sg =
   pl, sub, lazy (subst_signature sub sg)
 
 let set_nongen_level sub path =
-  Subst.set_nongen_level sub (Path.binding_time path)
+  Subst.set_nongen_level sub (Path.binding_time path - 1)
 
 let prefix_idents_and_subst root sub sg =
   let sub = set_nongen_level sub root in
@@ -1347,9 +1406,10 @@ let add_to_tbl id decl tbl =
     try Tbl.find id tbl with Not_found -> [] in
   Tbl.add id (decl :: decls) tbl
 
-let rec components_of_module ~deprecated env sub path mty =
+let rec components_of_module ~deprecated ~loc env sub path mty =
   {
     deprecated;
+    loc;
     comps = EnvLazy.create (env, sub, path, mty)
   }
 
@@ -1410,10 +1470,12 @@ and components_of_module_maker (env, sub, path, mty) =
             let deprecated =
               Builtin_attributes.deprecated_of_attrs md.md_attributes
             in
-            let comps = components_of_module ~deprecated !env sub path mty in
+            let comps =
+              components_of_module ~deprecated ~loc:md.md_loc !env sub path mty
+            in
             c.comp_components <-
               Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
-            env := store_module None id (Pident id) md !env !env;
+            env := store_module ~check:false None id (Pident id) md !env !env;
             incr pos
         | Sig_modtype(id, decl) ->
             let decl' = Subst.modtype_declaration sub decl in
@@ -1548,8 +1610,9 @@ and store_type_infos slot id path info env renv =
 and store_extension ~check slot id path ext env renv =
   let loc = ext.ext_loc in
   if check && not loc.Location.loc_ghost &&
-    Warnings.is_active (Warnings.Unused_extension ("", false, false))
+    Warnings.is_active (Warnings.Unused_extension ("", false, false, false))
   then begin
+    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
     let ty = Path.last ext.ext_type_path in
     let n = Ident.name id in
     let k = (ty, loc, n) in
@@ -1561,7 +1624,7 @@ and store_extension ~check slot id path ext env renv =
           if not (is_in_signature env) && not used.cu_positive then
             Location.prerr_warning loc
               (Warnings.Unused_extension
-                 (n, used.cu_pattern, used.cu_privatize)
+                 (n, is_exception, used.cu_pattern, used.cu_privatize)
               )
         )
     end;
@@ -1572,14 +1635,19 @@ and store_extension ~check slot id path ext env renv =
                 env.constrs renv.constrs;
     summary = Env_extension(env.summary, id, ext) }
 
-and store_module slot id path md env renv =
+and store_module ~check slot id path md env renv =
+  let loc = md.md_loc in
+  if check then
+    check_usage loc id (fun s -> Warnings.Unused_module s)
+      module_declarations;
+
   let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in
   { env with
     modules = EnvTbl.add slot (fun x -> `Module x) id (path, md)
         env.modules renv.modules;
     components =
       EnvTbl.add slot (fun x -> `Component x) id
-        (path, components_of_module ~deprecated
+        (path, components_of_module ~deprecated ~loc:md.md_loc
            env Subst.identity path md.md_type)
         env.components renv.components;
     summary = Env_module(env.summary, id, md) }
@@ -1611,7 +1679,8 @@ let components_of_functor_appl f env p1 p2 =
     let p = Papply(p1, p2) in
     let sub = Subst.add_module f.fcomp_param p2 Subst.identity in
     let mty = Subst.modtype sub f.fcomp_res in
-    let comps = components_of_module ~deprecated:None (*???*)
+    let comps = components_of_module ~deprecated:None ~loc:Location.none
+        (*???*)
         env Subst.identity p mty in
     Hashtbl.add f.fcomp_cache p2 comps;
     comps
@@ -1639,13 +1708,13 @@ let add_type ~check id info env =
 and add_extension ~check id ext env =
   store_extension ~check None id (Pident id) ext env env
 
-and add_module_declaration ?(arg=false) id md env =
+and add_module_declaration ?(arg=false) ~check id md env =
   let path =
     (*match md.md_type with
       Mty_alias path -> normalize_path env path
     | _ ->*) Pident id
   in
-  let env = store_module None id path md env env in
+  let env = store_module ~check None id path md env env in
   if arg then add_functor_arg id env else env
 
 and add_modtype id info env =
@@ -1658,18 +1727,21 @@ and add_cltype id ty env =
   store_cltype None id (Pident id) ty env env
 
 let add_module ?arg id mty env =
-  add_module_declaration ?arg id (md mty) env
+  add_module_declaration ~check:false ?arg id (md mty) env
 
-let add_local_constraint id info elv env =
+let add_local_type path info env =
+  { env with
+    local_constraints = PathMap.add path info env.local_constraints }
+
+let add_local_constraint path info elv env =
   match info with
-    {type_manifest = Some ty; type_newtype_level = Some (lv, _)} ->
+    {type_manifest = Some _; type_newtype_level = Some (lv, _)} ->
       (* elv is the expansion level, lv is the definition level *)
-      let env =
-        add_type ~check:false
-          id {info with type_newtype_level = Some (lv, elv)} env in
-      { env with local_constraints = true }
+      let info = {info with type_newtype_level = Some (lv, elv)} in
+      add_local_type path info env
   | _ -> assert false
 
+
 (* Insertion of bindings by name *)
 
 let enter store_fun name data env =
@@ -1679,7 +1751,7 @@ let enter_value ?check = enter (store_value ?check)
 and enter_type = enter (store_type ~check:true)
 and enter_extension = enter (store_extension ~check:true)
 and enter_module_declaration ?arg id md env =
-  add_module_declaration ?arg id md env
+  add_module_declaration ?arg ~check:true id md env
   (* let (id, env) = enter store_module name md env in
   (id, add_functor_arg ?arg id env) *)
 and enter_modtype = enter store_modtype
@@ -1697,7 +1769,7 @@ let add_item comp env =
     Sig_value(id, decl)     -> add_value id decl env
   | Sig_type(id, decl, _)   -> add_type ~check:false id decl env
   | Sig_typext(id, ext, _)  -> add_extension ~check:false id ext env
-  | Sig_module(id, md, _)   -> add_module_declaration id md env
+  | Sig_module(id, md, _)   -> add_module_declaration ~check:false id md env
   | Sig_modtype(id, decl)   -> add_modtype id decl env
   | Sig_class(id, decl, _)  -> add_class id decl env
   | Sig_class_type(id, decl, _) -> add_cltype id decl env
@@ -1711,7 +1783,7 @@ let rec add_signature sg env =
 
 let open_signature slot root sg env0 =
   (* First build the paths and substitution *)
-  let (pl, sub, sg) = prefix_idents_and_subst root Subst.identity sg in
+  let (pl, _sub, sg) = prefix_idents_and_subst root Subst.identity sg in
   let sg = Lazy.force sg in
 
   (* Then enter the components in the environment after substitution *)
@@ -1727,7 +1799,7 @@ let open_signature slot root sg env0 =
         | Sig_typext(id, ext, _) ->
             store_extension ~check:false slot (Ident.hide id) p ext env env0
         | Sig_module(id, mty, _) ->
-            store_module slot (Ident.hide id) p mty env env0
+            store_module ~check:false slot (Ident.hide id) p mty env env0
         | Sig_modtype(id, decl) ->
             store_modtype slot (Ident.hide id) p decl env env0
         | Sig_class(id, decl, _) ->
@@ -1818,6 +1890,7 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
     List.concat [
       if !Clflags.recursive_types then [Cmi_format.Rectypes] else [];
       if !Clflags.opaque then [Cmi_format.Opaque] else [];
+      (if !Clflags.unsafe_string then [Cmi_format.Unsafe_string] else []);
       (match deprecated with Some s -> [Deprecated s] | None -> []);
     ]
   in
@@ -1834,7 +1907,8 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
     (* Enter signature in persistent table so that imported_unit()
        will also return its crc *)
     let comps =
-      components_of_module ~deprecated empty Subst.identity
+      components_of_module ~deprecated ~loc:Location.none
+        empty Subst.identity
         (Pident(Ident.create_persistent modname)) (Mty_signature sg) in
     let ps =
       { ps_name = modname;
@@ -1877,17 +1951,17 @@ let find_all_simple_list proj1 proj2 f lid env acc =
   match lid with
     | None ->
       EnvTbl.fold_name
-        (fun id data acc -> f data acc)
+        (fun _id data acc -> f data acc)
         (proj1 env) acc
     | Some l ->
-      let p, desc = lookup_module_descr l env in
+      let (_p, desc) = lookup_module_descr l env in
       begin match get_components desc with
           Structure_comps c ->
             Tbl.fold
-              (fun s comps acc ->
+              (fun _s comps acc ->
                 match comps with
                   [] -> acc
-                | (data, pos) :: _ ->
+                | (data, _pos) :: _ ->
                   f data acc)
               (proj2 c) acc
         | Functor_comps _ ->
@@ -1951,7 +2025,9 @@ let (initial_safe_string, initial_unsafe_string) =
 
 (* Return the environment summary *)
 
-let summary env = env.summary
+let summary env =
+  if PathMap.is_empty env.local_constraints then env.summary
+  else Env_constraints (env.summary, env.local_constraints)
 
 let last_env = ref empty
 let last_reduced_env = ref empty
@@ -1997,6 +2073,11 @@ let report_error ppf = function
       fprintf ppf
         "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]"
         export import "The compilation flag -rectypes is required"
+  | Depend_on_unsafe_string_unit(import, export) ->
+      fprintf ppf
+        "@[<hov>Unit %s imports from %s, compiled with -unsafe-string.@ %s@]"
+        export import "This compiler has been configured in strict \
+                       -safe-string mode"
   | Missing_module(_, path1, path2) ->
       fprintf ppf "@[@[<hov>";
       if Path.same path1 path2 then

diff --git a/typing/env.mli b/typing/env.mli
index 8166db8288bc7be3290e645959f836f2b35e31a9..aa57630d856c5987b7e8727dac633032cb16e408 100644 (file)
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -17,6 +17,9 @@
 
 open Types
 
+module PathMap : Map.S with type key = Path.t
+                        and type 'a t = 'a Map.Make(Path).t
+
 type summary =
     Env_empty
   | Env_value of summary * Ident.t * value_description
@@ -28,6 +31,7 @@ type summary =
   | Env_cltype of summary * Ident.t * class_type_declaration
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
+  | Env_constraints of summary * type_declaration PathMap.t
 
 type t
 
@@ -35,6 +39,7 @@ val empty: t
 val initial_safe_string: t
 val initial_unsafe_string: t
 val diff: t -> t -> Ident.t list
+val copy_local: from:t -> t -> t
 
 type type_descriptions =
     constructor_description list * label_description list
@@ -48,6 +53,9 @@ val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list
 val same_types: t -> t -> bool
 val used_persistent: unit -> Concr.t
 val find_shadowed_types: Path.t -> t -> Path.t list
+val without_cmis: ('a -> 'b) -> 'a -> 'b
+        (* [without_cmis f arg] applies [f] to [arg], but does not
+           allow opening cmis during its execution *)
 
 (* Lookup by paths *)
 
@@ -73,6 +81,8 @@ val normalize_path: Location.t option -> t -> Path.t -> Path.t
    If the option is None, allow returning dangling paths.
    Otherwise raise a Missing_module error, and may add forgotten
    head as required global. *)
+val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
+(* Only normalize the prefix part of the path *)
 val reset_required_globals: unit -> unit
 val get_required_globals: unit -> Ident.t list
 val add_required_global: Ident.t -> unit
@@ -100,7 +110,10 @@ val lookup_all_labels:
   ?loc:Location.t ->
   Longident.t -> t -> (label_description * (unit -> unit)) list
 val lookup_type:
-  ?loc:Location.t -> Longident.t -> t -> Path.t * type_declaration
+  ?loc:Location.t -> Longident.t -> t -> Path.t
+  (* Since 4.04, this function no longer returns [type_description].
+     To obtain it, you should either call [Env.find_type], or replace
+     it by [Typetexp.find_type] *)
 val lookup_module:
   load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t
 val lookup_modtype:
@@ -126,11 +139,13 @@ val add_value:
 val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
 val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t
 val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t
-val add_module_declaration: ?arg:bool -> Ident.t -> module_declaration -> t -> t
+val add_module_declaration: ?arg:bool -> check:bool -> Ident.t ->
+  module_declaration -> t -> t
 val add_modtype: Ident.t -> modtype_declaration -> t -> t
 val add_class: Ident.t -> class_declaration -> t -> t
 val add_cltype: Ident.t -> class_type_declaration -> t -> t
-val add_local_constraint: Ident.t -> type_declaration -> int -> t -> t
+val add_local_constraint: Path.t -> type_declaration -> int -> t -> t
+val add_local_type: Path.t -> type_declaration -> t -> t
 
 (* Insertion of all fields of a signature. *)
 
@@ -217,6 +232,7 @@ type error =
   | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
+  | Depend_on_unsafe_string_unit of string * string
   | Missing_module of Location.t * Path.t * Path.t
   | Illegal_value_name of Location.t * string
 
@@ -228,6 +244,7 @@ val report_error: formatter -> error -> unit
 
 
 val mark_value_used: t -> string -> value_description -> unit
+val mark_module_used: t -> string -> Location.t -> unit
 val mark_type_used: t -> string -> type_declaration -> unit
 
 type constructor_usage = Positive | Pattern | Privatize
@@ -254,7 +271,8 @@ val check_modtype_inclusion:
 (* Forward declaration to break mutual recursion with Typecore. *)
 val add_delayed_check_forward: ((unit -> unit) -> unit) ref
 (* Forward declaration to break mutual recursion with Mtype. *)
-val strengthen: (t -> module_type -> Path.t -> module_type) ref
+val strengthen:
+    (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
 (* Forward declaration to break mutual recursion with Ctype. *)
 val same_constr: (t -> type_expr -> type_expr -> bool) ref
 
@@ -291,3 +309,14 @@ val fold_cltypes:
 (** Utilities *)
 val scrape_alias: t -> module_type -> module_type
 val check_value_name: string -> Location.t -> unit
+
+module Persistent_signature : sig
+  type t =
+    { filename : string; (** Name of the file containing the signature. *)
+      cmi : Cmi_format.cmi_infos }
+
+  (** Function used to load a persistent signature. The default is to look for
+      the .cmi file in the load path. This function can be overridden to load
+      it from memory, for instance to build a self-contained toplevel. *)
+  val load : (unit_name:string -> t option) ref
+end

diff --git a/typing/envaux.ml b/typing/envaux.ml
index b83046c350ba4037e39aa940662b6fbf37654cbc..53f4d8877b232fb3ba75f0d3bdd46f190ffc9c2e 100644 (file)
--- a/typing/envaux.ml
+++ b/typing/envaux.ml
@@ -55,7 +55,7 @@ let rec env_from_summary sum subst =
             (Subst.extension_constructor subst desc)
             (env_from_summary s subst)
       | Env_module(s, id, desc) ->
-          Env.add_module_declaration id
+          Env.add_module_declaration ~check:false id
             (Subst.module_declaration subst desc)
             (env_from_summary s subst)
       | Env_modtype(s, id, desc) ->
@@ -79,9 +79,16 @@ let rec env_from_summary sum subst =
           Env.open_signature Asttypes.Override path'
             (extract_sig env md.md_type) env
       | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' ->
-          Env.add_module_declaration id (Subst.module_declaration subst desc)
+          Env.add_module_declaration ~check:false
+            id (Subst.module_declaration subst desc)
             ~arg:true (env_from_summary s subst)
       | Env_functor_arg _ -> assert false
+      | Env_constraints(s, map) ->
+          PathMap.fold
+            (fun path info ->
+              Env.add_local_type (Subst.type_path subst path)
+                (Subst.type_declaration subst info))
+            map (env_from_summary s subst)
     in
       Hashtbl.add env_cache (sum, subst) env;
       env

diff --git a/typing/ident.mli b/typing/ident.mli
index 1c9b6e0471ac875a4679c60c39ef6640ac20640c..52dd54ea5b2ba567a13ba86b6beeb74f8b537f4d 100644 (file)
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -17,6 +17,14 @@
 
 type t = { stamp: int; name: string; mutable flags: int }
 
+include Identifiable.S with type t := t
+(* Notes:
+   - [equal] compares identifiers by name
+   - [compare x y] is 0 if [same x y] is true.
+   - [compare] compares identifiers by binding location
+*)
+
+
 val create: string -> t
 val create_persistent: string -> t
 val create_predef_exn: string -> t
@@ -25,8 +33,6 @@ val name: t -> string
 val unique_name: t -> string
 val unique_toplevel_name: t -> string
 val persistent: t -> bool
-val equal: t -> t -> bool
-        (* Compare identifiers by name. *)
 val same: t -> t -> bool
         (* Compare identifiers by binding location.
            Two identifiers are the same either if they are both
@@ -34,17 +40,12 @@ val same: t -> t -> bool
            [new], or if they are both persistent and have the same
            name. *)
 val compare: t -> t -> int
-        (* [compare x y] is 0 if [same x y] is true. *)
-val hash: t -> int
 val hide: t -> t
         (* Return an identifier with same name as the given identifier,
            but stamp different from any stamp returned by new.
            When put in a 'a tbl, this identifier can only be looked
            up by name. *)
 
-val compare : t -> t -> int
-(* Compare identifiers by binding location *)
-
 val make_global: t -> unit
 val global: t -> bool
 val is_predef_exn: t -> bool
@@ -54,9 +55,6 @@ val current_time: unit -> int
 val set_current_time: int -> unit
 val reinit: unit -> unit
 
-val print: Format.formatter -> t -> unit
-val output : out_channel -> t -> unit
-
 type 'a tbl
         (* Association tables from identifiers to type 'a. *)
 
@@ -73,5 +71,3 @@ val iter: (t -> 'a -> unit) -> 'a tbl -> unit
 (* Idents for sharing keys *)
 
 val make_key_generator : unit -> (t -> t)
-
-include Identifiable.S with type t := t

diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index 92e06f1bf1bc4240b805c57f868acbb9e6789165..10748bffd99991c7907d70449300e67fc8037e49 100644 (file)
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -47,7 +47,7 @@ let include_err ppf =
   function
   | CM_Virtual_class ->
       fprintf ppf "A class cannot be changed from virtual to concrete"
-  | CM_Parameter_arity_mismatch (ls, lp) ->
+  | CM_Parameter_arity_mismatch _ ->
       fprintf ppf
         "The classes do not have the same number of type parameters"
   | CM_Type_parameter_mismatch (env, trace) ->

diff --git a/typing/includecore.ml b/typing/includecore.ml
index a1bc3bdc5b23ed3324b858c9a0d422ff2973df77..382a33d6ca77e15ac6cea636ef94661eefa755de 100644 (file)
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -33,7 +33,7 @@ let value_descriptions env vd1 vd2 =
           let pc = {pc_desc = p; pc_type = vd2.Types.val_type;
                   pc_env = env; pc_loc = vd1.Types.val_loc; } in
           Tcoerce_primitive pc
-      | (_, Val_prim p) -> raise Dont_match
+      | (_, Val_prim _) -> raise Dont_match
       | (_, _) -> Tcoerce_none
   end else
     raise Dont_match
@@ -51,7 +51,7 @@ let private_flags decl1 decl2 =
 
 let is_absrow env ty =
   match ty.desc with
-    Tconstr(Pident id, _, _) ->
+    Tconstr(Pident _, _, _) ->
       begin match Ctype.expand_head env ty with
         {desc=Tobject _|Tvariant _} -> true
       | _ -> false
@@ -98,7 +98,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 =
       Ctype.equal env true (ty1::params1) (rest2::params2) &&
       let (fields1,rest1) = Ctype.flatten_fields fi1 in
       (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
-      let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+      let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
       miss2 = [] &&
       let tl1, tl2 =
         List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in
@@ -126,7 +126,8 @@ type type_mismatch =
   | Field_arity of Ident.t
   | Field_names of int * Ident.t * Ident.t
   | Field_missing of bool * Ident.t
-  | Record_representation of bool
+  | Record_representation of bool   (* true means second one is unboxed float *)
+  | Unboxed_representation of bool  (* true means second one is unboxed *)
   | Immediate
 
 let report_type_mismatch0 first second decl ppf err =
@@ -154,6 +155,10 @@ let report_type_mismatch0 first second decl ppf err =
       pr "Their internal representations differ:@ %s %s %s"
         (if b then second else first) decl
         "uses unboxed float representation"
+  | Unboxed_representation b ->
+      pr "Their internal representations differ:@ %s %s %s"
+         (if b then second else first) decl
+         "uses unboxed representation"
   | Immediate -> pr "%s is not an immediate type" first
 
 let report_type_mismatch first second decl ppf =
@@ -166,9 +171,9 @@ let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 =
   match arg1, arg2 with
   | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
       if List.length arg1 <> List.length arg2 then [Field_arity cstr]
-      else if Misc.for_all2
-          (fun ty1 ty2 -> Ctype.equal env true (ty1::params1) (ty2::params2))
-          (arg1) (arg2)
+      else if
+        (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
+        Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
       then [] else [Field_type cstr]
   | Types.Cstr_record l1, Types.Cstr_record l2 ->
       compare_records env params1 params2 0 l1 l2
@@ -212,7 +217,8 @@ and compare_records env params1 params2 n labels1 labels2 =
       else if mut1 <> mut2 then [Field_mutable lab1] else
       if Ctype.equal env true (arg1::params1)
                               (arg2::params2)
-      then compare_records env params1 params2 (n+1) rem1 rem2
+      then (* add arguments to the parameters, cf. PR#7378 *)
+        compare_records env (arg1::params1) (arg2::params2) (n+1) rem1 rem2
       else [Field_type lab1]
 
 let type_declarations ?(equality = false) env name decl1 id decl2 =
@@ -236,6 +242,15 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
         else [Constraint]
   in
   if err <> [] then err else
+  let err =
+    match (decl2.type_kind, decl1.type_unboxed.unboxed,
+           decl2.type_unboxed.unboxed) with
+    | Type_abstract, _, _ -> []
+    | _, true, false -> [Unboxed_representation false]
+    | _, false, true -> [Unboxed_representation true]
+    | _ -> []
+  in
+  if err <> [] then err else
   let err = match (decl1.type_kind, decl2.type_kind) with
       (_, Type_abstract) -> []
     | (Type_variant cstrs1, Type_variant cstrs2) ->

diff --git a/typing/includecore.mli b/typing/includecore.mli
index 17278a4aff703b3092508cf87bf32314a9161da6..8ddd59cddcdac1c1173f4d81512f0e2ab6cf41d6 100644 (file)
--- a/typing/includecore.mli
+++ b/typing/includecore.mli
@@ -33,6 +33,7 @@ type type_mismatch =
   | Field_names of int * Ident.t * Ident.t
   | Field_missing of bool * Ident.t
   | Record_representation of bool
+  | Unboxed_representation of bool
   | Immediate
 
 val value_descriptions:

diff --git a/typing/includemod.ml b/typing/includemod.ml
index 6f9b2eeb7472222ab45ab5caa4d4989a878ff866..f3a3caf5afe585efedf22b0cb78dca941f72ad48 100644 (file)
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -227,29 +227,50 @@ let rec modtypes env cxt subst mty1 mty2 =
 
 and try_modtypes env cxt subst mty1 mty2 =
   match (mty1, mty2) with
-  | (Mty_alias p1, Mty_alias p2) ->
+  | (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin
       if Env.is_functor_arg p2 env then
         raise (Error[cxt, env, Invalid_module_alias p2]);
-      if Path.same p1 p2 then Tcoerce_none else
-      let p1 = Env.normalize_path None env p1
-      and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
-      (* Should actually be Tcoerce_ignore, if it existed *)
-      if Path.same p1 p2 then Tcoerce_none else raise Dont_match
-  | (Mty_alias p1, _) ->
+      if not (Path.same p1 p2) then begin
+        let p1 = Env.normalize_path None env p1
+        and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
+        if not (Path.same p1 p2) then raise Dont_match
+      end;
+      match pres1, pres2 with
+      | Mta_present, Mta_present -> Tcoerce_none
+        (* Should really be Tcoerce_ignore if it existed *)
+      | Mta_absent, Mta_absent -> Tcoerce_none
+        (* Should really be Tcoerce_empty if it existed *)
+      | Mta_present, Mta_absent -> Tcoerce_none
+      | Mta_absent, Mta_present ->
+        let p1 = try
+            Env.normalize_path (Some Location.none) env p1
+          with Env.Error (Env.Missing_module (_, _, path)) ->
+            raise (Error[cxt, env, Unbound_module_path path])
+        in
+        Tcoerce_alias (p1, Tcoerce_none)
+    end
+  | (Mty_alias(pres1, p1), _) -> begin
       let p1 = try
         Env.normalize_path (Some Location.none) env p1
       with Env.Error (Env.Missing_module (_, _, path)) ->
         raise (Error[cxt, env, Unbound_module_path path])
       in
-      let mty1 = Mtype.strengthen env (expand_module_alias env cxt p1) p1 in
-      Tcoerce_alias (p1, modtypes env cxt subst mty1 mty2)
+      let mty1 =
+        Mtype.strengthen ~aliasable:true env
+          (expand_module_alias env cxt p1) p1
+      in
+      let cc = modtypes env cxt subst mty1 mty2 in
+      match pres1 with
+      | Mta_present -> cc
+      | Mta_absent -> Tcoerce_alias (p1, cc)
+    end
   | (Mty_ident p1, _) when may_expand_module_path env p1 ->
       try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
-  | (_, Mty_ident p2) ->
+  | (_, Mty_ident _) ->
       try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
   | (Mty_signature sig1, Mty_signature sig2) ->
       signatures env cxt subst sig1 sig2
-  | (Mty_functor(param1, None, res1), Mty_functor(param2, None, res2)) ->
+  | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
       begin match modtypes env (Body param1::cxt) subst res1 res2 with
         Tcoerce_none -> Tcoerce_none
       | cc -> Tcoerce_functor (Tcoerce_none, cc)
@@ -271,12 +292,14 @@ and try_modtypes env cxt subst mty1 mty2 =
 and try_modtypes2 env cxt mty1 mty2 =
   (* mty2 is an identifier *)
   match (mty1, mty2) with
-    (Mty_ident p1, Mty_ident p2) when Path.same p1 p2 ->
+    (Mty_ident p1, Mty_ident p2)
+    when Path.same (Env.normalize_path_prefix None env p1)
+                   (Env.normalize_path_prefix None env p2) ->
       Tcoerce_none
-  | (_, Mty_ident p2) ->
+  | (_, Mty_ident p2) when may_expand_module_path env p2 ->
       try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
   | (_, _) ->
-      assert false
+      raise Dont_match
 
 (* Inclusion between signatures *)
 
@@ -372,34 +395,35 @@ and signature_components old_env env cxt subst paired =
   let comps_rec rem = signature_components old_env env cxt subst rem in
   match paired with
     [] -> []
-  | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem ->
+  | (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem ->
       let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
       begin match valdecl2.val_kind with
-        Val_prim p -> comps_rec rem
+        Val_prim _ -> comps_rec rem
       | _ -> (pos, cc) :: comps_rec rem
       end
-  | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem ->
+  | (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem ->
       type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2;
       comps_rec rem
-  | (Sig_typext(id1, ext1, _), Sig_typext(id2, ext2, _), pos)
+  | (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos)
     :: rem ->
       extension_constructors env cxt subst id1 ext1 ext2;
       (pos, Tcoerce_none) :: comps_rec rem
-  | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem ->
+  | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
       let p1 = Pident id1 in
+      Env.mark_module_used env (Ident.name id1) mty1.md_loc;
       let cc =
         modtypes env (Module id1::cxt) subst
-          (Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1)
-          mty2.md_type in
+          (Mtype.strengthen ~aliasable:true env mty1.md_type p1) mty2.md_type
+      in
       (pos, cc) :: comps_rec rem
-  | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem ->
+  | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
       modtype_infos env cxt subst id1 info1 info2;
       comps_rec rem
-  | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem ->
+  | (Sig_class(id1, decl1, _), Sig_class(_id2, decl2, _), pos) :: rem ->
       class_declarations ~old_env env cxt subst id1 decl1 decl2;
       (pos, Tcoerce_none) :: comps_rec rem
   | (Sig_class_type(id1, info1, _),
-     Sig_class_type(id2, info2, _), pos) :: rem ->
+     Sig_class_type(_id2, info2, _), _pos) :: rem ->
       class_type_declarations ~old_env env cxt subst id1 info1 info2;
       comps_rec rem
   | _ ->
@@ -413,7 +437,7 @@ and modtype_infos env cxt subst id info1 info2 =
   try
     match (info1.mtd_type, info2.mtd_type) with
       (None, None) -> ()
-    | (Some mty1, None) -> ()
+    | (Some _, None) -> ()
     | (Some mty1, Some mty2) ->
         check_modtype_equiv env cxt' mty1 mty2
     | (None, Some mty2) ->
@@ -427,18 +451,27 @@ and check_modtype_equiv env cxt mty1 mty2 =
      modtypes env cxt Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
-  | (c1, c2) ->
+  | (_c1, _c2) ->
       (* Format.eprintf "@[c1 = %a@ c2 = %a@]@."
-        print_coercion c1 print_coercion c2; *)
+        print_coercion _c1 print_coercion _c2; *)
       raise(Error [cxt, env, Modtype_permutation])
 
 (* Simplified inclusion check between module types (for Env) *)
 
+let can_alias env path =
+  let rec no_apply = function
+    | Pident _ -> true
+    | Pdot(p, _, _) -> no_apply p
+    | Papply _ -> false
+  in
+  no_apply path && not (Env.is_functor_arg path env)
+
 let check_modtype_inclusion env mty1 path1 mty2 =
   try
+    let aliasable = can_alias env path1 in
     ignore(modtypes env [] Subst.identity
-                    (Mtype.strengthen env mty1 path1) mty2)
-  with Error reasons ->
+                    (Mtype.strengthen ~aliasable env mty1 path1) mty2)
+  with Error _ ->
     raise Not_found
 
 let _ = Env.check_modtype_inclusion := check_modtype_inclusion

diff --git a/typing/mtype.ml b/typing/mtype.ml
index c1995dc3b9eef4107e9ca79b45733a813b3d205b..063cc366dcdb6904bfc2609d3e88b12b9b5327fa 100644 (file)
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -33,26 +33,31 @@ let rec scrape env mty =
 let freshen mty =
   Subst.modtype Subst.identity mty
 
-let rec strengthen env mty p =
+let rec strengthen ~aliasable env mty p =
   match scrape env mty with
     Mty_signature sg ->
-      Mty_signature(strengthen_sig env sg p 0)
+      Mty_signature(strengthen_sig ~aliasable env sg p 0)
   | Mty_functor(param, arg, res)
     when !Clflags.applicative_functors && Ident.name param <> "*" ->
-      Mty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
+      Mty_functor(param, arg,
+        strengthen ~aliasable:false env res (Papply(p, Pident param)))
   | mty ->
       mty
 
-and strengthen_sig env sg p pos =
+and strengthen_sig ~aliasable env sg p pos =
   match sg with
     [] -> []
-  | (Sig_value(id, desc) as sigelt) :: rem ->
-      let nextpos = match desc.val_kind with Val_prim _ -> pos | _ -> pos+1 in
-      sigelt :: strengthen_sig env rem p nextpos
-  | Sig_type(id, {type_kind=Type_abstract}, rs) ::
+  | (Sig_value(_, desc) as sigelt) :: rem ->
+      let nextpos =
+        match desc.val_kind with
+        | Val_prim _ -> pos
+        | _ -> pos + 1
+      in
+      sigelt :: strengthen_sig ~aliasable env rem p nextpos
+  | Sig_type(id, {type_kind=Type_abstract}, _) ::
     (Sig_type(id', {type_private=Private}, _) :: _ as rem)
     when Ident.name id = Ident.name id' ^ "#row" ->
-      strengthen_sig env rem p pos
+      strengthen_sig ~aliasable env rem p pos
   | Sig_type(id, decl, rs) :: rem ->
       let newdecl =
         match decl.type_manifest, decl.type_private, decl.type_kind with
@@ -67,18 +72,16 @@ and strengthen_sig env sg p pos =
             else
               { decl with type_manifest = manif }
       in
-      Sig_type(id, newdecl, rs) :: strengthen_sig env rem p pos
-  | (Sig_typext(id, ext, es) as sigelt) :: rem ->
-      sigelt :: strengthen_sig env rem p (pos+1)
+      Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos
+  | (Sig_typext _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
   | Sig_module(id, md, rs) :: rem ->
       let str =
-        if Env.is_functor_arg p env then
-          strengthen_decl env md (Pdot(p, Ident.name id, pos))
-        else
-          {md with md_type = Mty_alias (Pdot(p, Ident.name id, pos))}
+        strengthen_decl ~aliasable env md (Pdot(p, Ident.name id, pos))
       in
       Sig_module(id, str, rs)
-      :: strengthen_sig (Env.add_module_declaration id md env) rem p (pos+1)
+      :: strengthen_sig ~aliasable
+        (Env.add_module_declaration ~check:false id md env) rem p (pos+1)
       (* Need to add the module in case it defines manifest module types *)
   | Sig_modtype(id, decl) :: rem ->
       let newdecl =
@@ -89,15 +92,18 @@ and strengthen_sig env sg p pos =
             decl
       in
       Sig_modtype(id, newdecl) ::
-      strengthen_sig (Env.add_modtype id decl env) rem p pos
+      strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos
       (* Need to add the module type in case it is manifest *)
-  | (Sig_class(id, decl, rs) as sigelt) :: rem ->
-      sigelt :: strengthen_sig env rem p (pos+1)
-  | (Sig_class_type(id, decl, rs) as sigelt) :: rem ->
-      sigelt :: strengthen_sig env rem p pos
+  | (Sig_class _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
+  | (Sig_class_type _ as sigelt) :: rem ->
+      sigelt :: strengthen_sig ~aliasable env rem p pos
 
-and strengthen_decl env md p =
-  {md with md_type = strengthen env md.md_type p}
+and strengthen_decl ~aliasable env md p =
+  match md.md_type with
+  | Mty_alias _ -> md
+  | _ when aliasable -> {md with md_type = Mty_alias(Mta_present, p)}
+  | mty -> {md with md_type = strengthen ~aliasable env mty p}
 
 let () = Env.strengthen := strengthen
 
@@ -115,7 +121,7 @@ let nondep_supertype env mid mty =
         if Path.isfree mid p then
           nondep_mty env va (Env.find_modtype_expansion p env)
         else mty
-    | Mty_alias p ->
+    | Mty_alias(_, p) ->
         if Path.isfree mid p then
           nondep_mty env va (Env.find_module p env).md_type
         else mty
@@ -171,7 +177,7 @@ let nondep_supertype env mid mty =
 
 let enrich_typedecl env p decl =
   match decl.type_manifest with
-    Some ty -> decl
+    Some _ -> decl
   | None ->
       try
         let orig_decl = Env.find_type p env in
@@ -203,22 +209,23 @@ and enrich_item env p = function
 
 let rec type_paths env p mty =
   match scrape env mty with
-    Mty_ident p -> []
-  | Mty_alias p -> []
+    Mty_ident _ -> []
+  | Mty_alias _ -> []
   | Mty_signature sg -> type_paths_sig env p 0 sg
-  | Mty_functor(param, arg, res) -> []
+  | Mty_functor _ -> []
 
 and type_paths_sig env p pos sg =
   match sg with
     [] -> []
-  | Sig_value(id, decl) :: rem ->
+  | Sig_value(_id, decl) :: rem ->
       let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
       type_paths_sig env p pos' rem
-  | Sig_type(id, decl, _) :: rem ->
+  | Sig_type(id, _decl, _) :: rem ->
       Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
   | Sig_module(id, md, _) :: rem ->
       type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @
-      type_paths_sig (Env.add_module_declaration id md env) p (pos+1) rem
+      type_paths_sig (Env.add_module_declaration ~check:false id md env)
+        p (pos+1) rem
   | Sig_modtype(id, decl) :: rem ->
       type_paths_sig (Env.add_modtype id decl env) p pos rem
   | (Sig_typext _ | Sig_class _) :: rem ->
@@ -228,25 +235,27 @@ and type_paths_sig env p pos sg =
 
 let rec no_code_needed env mty =
   match scrape env mty with
-    Mty_ident p -> false
+    Mty_ident _ -> false
   | Mty_signature sg -> no_code_needed_sig env sg
   | Mty_functor(_, _, _) -> false
-  | Mty_alias p -> true
+  | Mty_alias(Mta_absent, _) -> true
+  | Mty_alias(Mta_present, _) -> false
 
 and no_code_needed_sig env sg =
   match sg with
     [] -> true
-  | Sig_value(id, decl) :: rem ->
+  | Sig_value(_id, decl) :: rem ->
       begin match decl.val_kind with
       | Val_prim _ -> no_code_needed_sig env rem
       | _ -> false
       end
   | Sig_module(id, md, _) :: rem ->
       no_code_needed env md.md_type &&
-      no_code_needed_sig (Env.add_module_declaration id md env) rem
+      no_code_needed_sig
+        (Env.add_module_declaration ~check:false id md env) rem
   | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem ->
       no_code_needed_sig env rem
-  | (Sig_typext _ | Sig_class _) :: rem ->
+  | (Sig_typext _ | Sig_class _) :: _ ->
       false
 
 
@@ -294,13 +303,8 @@ let contains_type env mty =
 
 (* Remove module aliases from a signature *)
 
-module P = struct
-  type t = Path.t
-  let compare p1 p2 =
-    if Path.same p1 p2 then 0 else compare p1 p2
-end
-module PathSet = Set.Make (P)
-module PathMap = Map.Make (P)
+module PathSet = Set.Make (Path)
+module PathMap = Map.Make (Path)
 module IdentSet = Set.Make (Ident)
 
 let rec get_prefixes = function
@@ -347,7 +351,7 @@ let collect_arg_paths mty =
   and it_signature_item it si =
     type_iterators.it_signature_item it si;
     match si with
-      Sig_module (id, {md_type=Mty_alias p}, _) ->
+      Sig_module (id, {md_type=Mty_alias(_, p)}, _) ->
         bindings := Ident.add id p !bindings
     | Sig_module (id, {md_type=Mty_signature sg}, _) ->
         List.iter

diff --git a/typing/mtype.mli b/typing/mtype.mli
index 2aaafaefe244d954c7efbf0a2b32673fc7b88eb1..3f07db4acb7c800d4d7188c8656b038b5c365d63 100644 (file)
--- a/typing/mtype.mli
+++ b/typing/mtype.mli
@@ -24,10 +24,11 @@ val scrape: Env.t -> module_type -> module_type
 val freshen: module_type -> module_type
         (* Return an alpha-equivalent copy of the given module type
            where bound identifiers are fresh. *)
-val strengthen: Env.t -> module_type -> Path.t -> module_type
+val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
         (* Strengthen abstract type components relative to the
            given path. *)
-val strengthen_decl: Env.t -> module_declaration -> Path.t -> module_declaration
+val strengthen_decl:
+  aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
 val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type
         (* Return the smallest supertype of the given type
            in which the given ident does not appear.

diff --git a/typing/oprint.ml b/typing/oprint.ml
index 5860c6028f73685fe0c8e681effe24bf9378c3ab..02f236ccb70034c173f6aa5246eab4811cfbbef3 100644 (file)
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -431,7 +431,7 @@ and print_out_sig_item ppf =
   | Osig_typext (ext, Oext_exception) ->
       fprintf ppf "@[<2>exception %a@]"
         print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type)
-  | Osig_typext (ext, es) ->
+  | Osig_typext (ext, _es) ->
       print_out_extension_constructor ppf ext
   | Osig_modtype (name, Omty_abstract) ->
       fprintf ppf "@[<2>module type %s@]" name
@@ -506,6 +506,9 @@ and print_out_type_decl kwd ppf td =
   let print_immediate ppf =
     if td.otype_immediate then fprintf ppf " [%@%@immediate]" else ()
   in
+  let print_unboxed ppf =
+    if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
+  in
   let print_out_tkind ppf = function
   | Otyp_abstract -> ()
   | Otyp_record lbls ->
@@ -523,13 +526,19 @@ and print_out_type_decl kwd ppf td =
         print_private td.otype_private
         !out_type ty
   in
-  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t@]"
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t%t@]"
     print_name_params
     print_out_tkind ty
     print_constraints
     print_immediate
+    print_unboxed
 
 and print_out_constr ppf (name, tyl,ret_type_opt) =
+  let name =
+    match name with
+    | "::" -> "(::)"   (* #7200 *)
+    | s -> s
+  in
   match ret_type_opt with
   | None ->
       begin match tyl with

diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 7d4cb5b6e1f06de308c0fc4100f7764025b27edb..b926c920a335c2148104a2a4ded0f8776efc64f2 100644 (file)
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -106,6 +106,7 @@ and out_type_decl =
     otype_type: out_type;
     otype_private: Asttypes.private_flag;
     otype_immediate: bool;
+    otype_unboxed: bool;
     otype_cstrs: (out_type * out_type) list }
 and out_extension_constructor =
   { oext_name: string;

diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index cc2a780f4c5425d4507bcad455164de1bcd5752e..1ebae6e8436e800866ff1e356b78b91332bc908b 100644 (file)
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -93,9 +93,9 @@ let rec compat p q =
   | Tpat_lazy p, Tpat_lazy q -> compat p q
   | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) ->
       c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
-  | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
+  | Tpat_variant(l1,Some p1, _r1), Tpat_variant(l2,Some p2,_) ->
       l1=l2 && compat p1 p2
-  | Tpat_variant (l1,None,r1), Tpat_variant(l2,None,_) ->
+  | Tpat_variant (l1,None, _r1), Tpat_variant(l2,None,_) ->
       l1 = l2
   | Tpat_variant (_, None, _), Tpat_variant (_,Some _, _) -> false
   | Tpat_variant (_, Some _, _), Tpat_variant (_, None, _) -> false
@@ -137,6 +137,13 @@ let get_type_path ty tenv =
 open Format
 ;;
 
+let pretty_record_elision_mark ppf = function
+  | [] -> () (* should not happen, empty record pattern *)
+  | (_, lbl, _) :: q ->
+      (* we assume that there is no label repetitions here *)
+      if Array.length lbl.lbl_all > 1 + List.length q then
+        fprintf ppf ";@ _@ "
+
 let is_cons = function
 | {cstr_name = "::"} -> true
 | _ -> false
@@ -156,15 +163,17 @@ let rec pretty_val ppf v =
         begin match cstr with
           | Tpat_unpack ->
             fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
-          | Tpat_constraint ctyp ->
+          | Tpat_constraint _ ->
             fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
           | Tpat_type _ ->
             fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
+          | Tpat_open _ ->
+              fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
         end
     | [] ->
   match v.pat_desc with
   | Tpat_any -> fprintf ppf "_"
-  | Tpat_var (x,_) -> Ident.print ppf x
+  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
   | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
   | Tpat_tuple vs ->
       fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
@@ -185,12 +194,13 @@ let rec pretty_val ppf v =
   | Tpat_variant (l, Some w, _) ->
       fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
   | Tpat_record (lvs,_) ->
-      fprintf ppf "@[{%a}@]"
-        pretty_lvals
-        (List.filter
-           (function
-             | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
-             | _ -> true) lvs)
+      let filtered_lvs = List.filter
+          (function
+            | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+            | _ -> true) lvs in
+      fprintf ppf "@[{%a%a}@]"
+        pretty_lvals filtered_lvs
+        pretty_record_elision_mark filtered_lvs
   | Tpat_array vs ->
       fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
   | Tpat_lazy v ->
@@ -323,8 +333,8 @@ let all_record_args lbls = match lbls with
 (* Build argument list when p2 >= p1, where p1 is a simple pattern *)
 let rec simple_match_args p1 p2 = match p2.pat_desc with
 | Tpat_alias (p2,_,_) -> simple_match_args p1 p2
-| Tpat_construct(_, cstr, args) -> args
-| Tpat_variant(lab, Some arg, _) -> [arg]
+| Tpat_construct(_, _, args) -> args
+| Tpat_variant(_, Some arg, _) -> [arg]
 | Tpat_tuple(args)  -> args
 | Tpat_record(args,_) ->  extract_fields (record_arg p1) args
 | Tpat_array(args) -> args
@@ -455,7 +465,7 @@ let do_set_args erase_mutable q r = match q with
     make_pat
       (Tpat_variant (l, arg, row)) q.pat_type q.pat_env::
     rest
-| {pat_desc = Tpat_lazy omega} ->
+| {pat_desc = Tpat_lazy _omega} ->
     begin match r with
       arg::rest ->
         make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest
@@ -583,7 +593,7 @@ let close_variant env row =
   let row = Btype.row_repr row in
   let nm =
     List.fold_left
-      (fun nm (tag,f) ->
+      (fun nm (_tag,f) ->
         match Btype.row_field_repr f with
         | Reither(_, _, false, e) ->
             (* m=false means that this tag is not explicitly matched *)
@@ -609,23 +619,8 @@ let row_of_pat pat =
   not.
 *)
 
-let generalized_constructor x =
-  match x with
-    ({pat_desc = Tpat_construct(_,c,_);pat_env=env},_) ->
-      c.cstr_generalized
-  | _ -> assert false
-
-let clean_env env =
-  let rec loop =
-    function
-      | [] -> []
-      | x :: xs ->
-          if generalized_constructor x then loop xs else x :: loop xs
-  in
-  loop env
-
 let full_match closing env =  match env with
-| ({pat_desc = Tpat_construct(_,c,_);pat_type=typ},_) :: _ ->
+| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ ->
     if c.cstr_consts < 0 then false (* extensions *)
     else List.length env = c.cstr_consts + c.cstr_nonconsts
 | ({pat_desc = Tpat_variant _} as p,_) :: _ ->
@@ -718,7 +713,7 @@ let pats_of_type ?(always=false) env ty =
         List.for_all (fun cd -> cd.Types.cd_res <> None) cl ->
           let cstrs = fst (Env.find_type_descrs path env) in
           List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs
-      | Type_record (ldl, _) ->
+      | Type_record _ ->
           let labels = snd (Env.find_type_descrs path env) in
           let fields =
             List.map (fun ld ->
@@ -748,14 +743,6 @@ let rec get_variant_constructors env ty =
     end
   | _ -> fatal_error "Parmatch.get_variant_constructors"
 
-let rec map_filter f  =
-  function
-      [] -> []
-    | x :: xs ->
-        match f x with
-        | None -> map_filter f xs
-        | Some y -> y :: map_filter f xs
-
 (* Sends back a pattern that complements constructor tags all_tag *)
 let complete_constrs p all_tags =
   let c =
@@ -794,11 +781,11 @@ let build_other_constant proj make first next p env =
 *)
 
 let build_other ext env = match env with
-| ({pat_desc = Tpat_construct (lid,
-      ({cstr_tag=Cstr_extension _} as c),_)},_) :: _ ->
-    let c = {c with cstr_name = "*extension*"} in
-      make_pat (Tpat_construct(lid, c, [])) Ctype.none Env.empty
-| ({pat_desc = Tpat_construct (_, cd,_)} as p,_) :: _ ->
+| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ ->
+        (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
+        make_pat (Tpat_var (Ident.create "*extension*",
+                            {lid with txt="*extension*"})) Ctype.none Env.empty
+| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
     begin match ext with
     | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
         extra_pat
@@ -896,7 +883,7 @@ let build_other ext env = match env with
       (function f -> Tpat_constant(Const_float (string_of_float f)))
       0.0 (fun f -> f +. 1.0) p env
 
-| ({pat_desc = Tpat_array args} as p,_)::_ ->
+| ({pat_desc = Tpat_array _} as p,_)::_ ->
     let all_lengths =
       List.map
         (fun (p,_) -> match p.pat_desc with
@@ -1020,12 +1007,14 @@ type 'a result =
   | Rnone           (* No matching value *)
   | Rsome of 'a     (* This matching value *)
 
+(*
 let rec try_many  f = function
   | [] -> Rnone
   | (p,pss)::rest ->
       match f (p,pss) with
       | Rnone -> try_many  f rest
       | r -> r
+*)
 
 let rappend r1 r2 =
   match r1, r2 with
@@ -1214,7 +1203,7 @@ let rec pressure_variants tdefs = function
         [] -> pressure_variants tdefs (filter_extra pss)
       | constrs ->
           let rec try_non_omega = function
-              (p,pss) :: rem ->
+              (_p,pss) :: rem ->
                 let ok = pressure_variants tdefs pss in
                 try_non_omega rem && ok
             | [] -> true
@@ -1500,7 +1489,7 @@ let rec le_pat p q =
       c1.cstr_tag = c2.cstr_tag && le_pats ps qs
   | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
       (l1 = l2 && le_pat p1 p2)
-  | Tpat_variant(l1,None,r1), Tpat_variant(l2,None,_) ->
+  | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
       l1 = l2
   | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false
   | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs
@@ -1555,7 +1544,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
           when  l1=l2 ->
             let r=lub p1 p2 in
             make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env
-| Tpat_variant (l1,None,row), Tpat_variant(l2,None,_)
+| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_)
               when l1 = l2 -> p
 | Tpat_record (l1,closed),Tpat_record (l2,_) ->
     let rs = record_lubs l1 l2 in
@@ -1708,6 +1697,8 @@ module Conv = struct
       match pat.pat_desc with
         Tpat_or (pa,pb,_) ->
           mkpat (Ppat_or (loop pa, loop pb))
+      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+          mkpat (Ppat_var nm)
       | Tpat_any
       | Tpat_var _ ->
           mkpat Ppat_any
@@ -1727,7 +1718,7 @@ module Conv = struct
             | lst -> Some (mkpat (Ppat_tuple lst))
           in
           mkpat (Ppat_construct(lid, arg))
-      | Tpat_variant(label,p_opt,row_desc) ->
+      | Tpat_variant(label,p_opt,_row_desc) ->
           let arg = Misc.may_map loop p_opt in
           mkpat (Ppat_variant(label, arg))
       | Tpat_record (subpatterns, _closed_flag) ->
@@ -1754,7 +1745,7 @@ end
 let contains_extension pat =
   let r = ref false in
   let rec loop = function
-      {pat_desc=Tpat_construct(_, {cstr_name="*extension*"}, _)} ->
+      {pat_desc=Tpat_var (_, {txt="*extension*"})} ->
         r := true
     | p -> Typedtree.iter_pattern_desc loop p.pat_desc
   in loop pat; !r
@@ -1789,9 +1780,14 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
         let v =
           match pred with
           | Some pred ->
-              if false then Some u else
               let (pattern,constrs,labels) = Conv.conv u in
-              pred constrs labels pattern
+              let u' = pred constrs labels pattern in
+              (* pretty_pat u;
+              begin match u' with
+                None -> prerr_endline ": impossible"
+              | Some _ -> prerr_endline ": possible"
+              end; *)
+              u'
           | None -> Some u
         in
         begin match v with
@@ -1859,7 +1855,8 @@ let extendable_path path =
     Path.same path Predef.path_option)
 
 let rec collect_paths_from_pat r p = match p.pat_desc with
-| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps) ->
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps)
+  ->
     let path =  get_type_path p.pat_type p.pat_env in
     List.fold_left
       collect_paths_from_pat
@@ -1915,7 +1912,7 @@ let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
 (* Exported unused clause check *)
 (********************************)
 
-let check_unused pred tdefs casel =
+let check_unused pred casel =
   if Warnings.is_active Warnings.Unused_match
   || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then
     let rec do_rec pref = function

diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index e2122a686459ca09931af0f9863fc69a9e45954d..3dcb6dde159d749703a77d7d9b1a7d85ff8dd4bc 100644 (file)
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -71,7 +71,7 @@ val check_unused:
      (string, constructor_description) Hashtbl.t ->
      (string, label_description) Hashtbl.t ->
      Parsetree.pattern -> pattern option) ->
-    Env.t -> case list -> unit
+    case list -> unit
 
 (* Irrefutability tests *)
 val irrefutable : pattern -> bool

diff --git a/typing/path.ml b/typing/path.ml
index 035f122218867e1e292520427a07627217ab0580..a1a81015102e363d5877e505022cf80e4596a621 100644 (file)
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -23,33 +23,45 @@ let nopos = -1
 let rec same p1 p2 =
   match (p1, p2) with
     (Pident id1, Pident id2) -> Ident.same id1 id2
-  | (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) -> s1 = s2 && same p1 p2
+  | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> s1 = s2 && same p1 p2
   | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
        same fun1 fun2 && same arg1 arg2
   | (_, _) -> false
 
+let rec compare p1 p2 =
+  match (p1, p2) with
+    (Pident id1, Pident id2) -> Ident.compare id1 id2
+  | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) ->
+      let h = compare p1 p2 in
+      if h <> 0 then h else String.compare s1 s2
+  | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
+      let h = compare fun1 fun2 in
+      if h <> 0 then h else compare arg1 arg2
+  | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1
+  | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1
+
 let rec isfree id = function
     Pident id' -> Ident.same id id'
-  | Pdot(p, s, pos) -> isfree id p
+  | Pdot(p, _s, _pos) -> isfree id p
   | Papply(p1, p2) -> isfree id p1 || isfree id p2
 
 let rec binding_time = function
     Pident id -> Ident.binding_time id
-  | Pdot(p, s, pos) -> binding_time p
+  | Pdot(p, _s, _pos) -> binding_time p
   | Papply(p1, p2) -> max (binding_time p1) (binding_time p2)
 
-let kfalse x = false
+let kfalse _ = false
 
 let rec name ?(paren=kfalse) = function
     Pident id -> Ident.name id
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
   | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
 
 let rec head = function
     Pident id -> id
-  | Pdot(p, s, pos) -> head p
-  | Papply(p1, p2) -> assert false
+  | Pdot(p, _s, _pos) -> head p
+  | Papply _ -> assert false
 
 let heads p =
   let rec heads p acc = match p with

diff --git a/typing/path.mli b/typing/path.mli
index 7dac627c84c29a08f2c4e9fc624d0d68f75b3734..4853f925c8169cc048a57847729b497f837e17fa 100644 (file)
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -21,6 +21,7 @@ type t =
   | Papply of t * t
 
 val same: t -> t -> bool
+val compare: t -> t -> int
 val isfree: Ident.t -> t -> bool
 val binding_time: t -> int
 

diff --git a/typing/predef.ml b/typing/predef.ml
index db3d714caa8d762107002531eac2d3dbfe48df3f..a16997f96e6b01cb58983ac24a240b125dc2c5a8 100644 (file)
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -125,6 +125,7 @@ let decl_abstr =
    type_newtype_level = None;
    type_attributes = [];
    type_immediate = false;
+   type_unboxed = unboxed_false_default_false;
   }
 
 let decl_abstr_imm = {decl_abstr with type_immediate = true}

diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index abd9cb805109138852b3e9c4c9706453b50262b7..e5dc6157b48aa424f00cd7f14a669d60ffb153d1 100644 (file)
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -53,9 +53,9 @@ let ident_pervasive = Ident.create_persistent "Pervasives"
 let rec tree_of_path = function
   | Pident id ->
       Oide_ident (ident_name id)
-  | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
+  | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive ->
       Oide_ident s
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       Oide_dot (tree_of_path p, s)
   | Papply(p1, p2) ->
       Oide_apply (tree_of_path p1, tree_of_path p2)
@@ -63,9 +63,9 @@ let rec tree_of_path = function
 let rec path ppf = function
   | Pident id ->
       ident ppf id
-  | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
+  | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive ->
       pp_print_string ppf s
-  | Pdot(p, s, pos) ->
+  | Pdot(p, s, _pos) ->
       path ppf p;
       pp_print_char ppf '.';
       pp_print_string ppf s
@@ -96,11 +96,22 @@ let raw_list pr ppf = function
       fprintf ppf "@[<1>[%a%t]@]" pr a
         (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
 
+let kind_vars = ref []
+let kind_count = ref 0
+
 let rec safe_kind_repr v = function
     Fvar {contents=Some k}  ->
       if List.memq k v then "Fvar loop" else
       safe_kind_repr (k::v) k
-  | Fvar _ -> "Fvar None"
+  | Fvar r ->
+      let vid =
+        try List.assq r !kind_vars
+        with Not_found ->
+          let c = incr kind_count; !kind_count in
+          kind_vars := (r,c) :: !kind_vars;
+          c
+      in
+      Printf.sprintf "Fvar {None}@%d" vid
   | Fpresent -> "Fpresent"
   | Fabsent -> "Fabsent"
 
@@ -118,7 +129,7 @@ let rec safe_repr v = function
 
 let rec list_of_memo = function
     Mnil -> []
-  | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem
+  | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem
   | Mlink rem -> list_of_memo !rem
 
 let print_name ppf = function
@@ -200,9 +211,9 @@ and raw_field ppf = function
   | Rabsent -> fprintf ppf "Rabsent"
 
 let raw_type_expr ppf t =
-  visited := [];
+  visited := []; kind_vars := []; kind_count := 0;
   raw_type ppf t;
-  visited := []
+  visited := []; kind_vars := []
 
 let () = Btype.print_raw := raw_type_expr
 
@@ -232,20 +243,7 @@ let printing_depth = ref 0
 let printing_cont = ref ([] : Env.iter_cont list)
 let printing_old = ref Env.empty
 let printing_pers = ref Concr.empty
-module Path2 = struct
-  include Path
-  let rec compare p1 p2 =
-    (* must ignore position when comparing paths *)
-    match (p1, p2) with
-      (Pdot(p1, s1, pos1), Pdot(p2, s2, pos2)) ->
-        let c = compare p1 p2 in
-        if c <> 0 then c else String.compare s1 s2
-    | (Papply(fun1, arg1), Papply(fun2, arg2)) ->
-        let c = compare fun1 fun2 in
-        if c <> 0 then c else compare arg1 arg2
-    | _ -> Pervasives.compare p1 p2
-end
-module PathMap = Map.Make(Path2)
+module PathMap = Map.Make(Path)
 let printing_map = ref PathMap.empty
 
 let same_type t t' = repr t == repr t'
@@ -278,7 +276,8 @@ let rec normalize_type_path ?(cache=false) env p =
     | ty ->
         (p, Nth (index params ty))
   with
-    Not_found -> (p, Id)
+    Not_found ->
+      (Env.normalize_path None env p, Id)
 
 let penalty s =
   if s <> "" && s.[0] = '_' then
@@ -317,7 +316,7 @@ let set_printing_env env =
     (* printf "Recompute printing_map.@."; *)
     let cont =
       Env.iter_types
-        (fun p (p', decl) ->
+        (fun p (p', _decl) ->
           let (p1, s1) = normalize_type_path env p' ~cache:true in
           (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *)
           if s1 = Id then
@@ -336,6 +335,9 @@ let wrap_printing_env env f =
   set_printing_env env;
   try_finally f (fun () -> set_printing_env Env.empty)
 
+let wrap_printing_env env f =
+  Env.without_cmis (wrap_printing_env env) f
+
 let is_unambiguous path env =
   let l = Env.find_shadowed_types path env in
   List.exists (Path.same path) l || (* concrete paths are ok *)
@@ -349,7 +351,7 @@ let is_unambiguous path env =
       (* also allow repeatedly defining and opening (for toplevel) *)
       let id = lid_of_path p in
       List.for_all (fun p -> lid_of_path p = id) rem &&
-      Path.same p (fst (Env.lookup_type id env))
+      Path.same p (Env.lookup_type id env)
 
 let rec get_best_path r =
   match !r with
@@ -483,7 +485,7 @@ let rec mark_loops_rec visited ty =
         mark_loops_rec visited ty1; mark_loops_rec visited ty2
     | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
     | Tconstr(p, tyl, _) ->
-        let (p', s) = best_type_path p in
+        let (_p', s) = best_type_path p in
         List.iter (mark_loops_rec visited) (apply_subst s tyl)
     | Tpackage (_, _, tyl) ->
         List.iter (mark_loops_rec visited) tyl
@@ -494,7 +496,7 @@ let rec mark_loops_rec visited ty =
           if not (static_row row) then
             visited_objects := px :: !visited_objects;
           match row.row_name with
-          | Some(p, tyl) when namable_row row ->
+          | Some(_p, tyl) when namable_row row ->
               List.iter (mark_loops_rec visited) tyl
           | _ ->
               iter_row (mark_loops_rec visited) row
@@ -575,7 +577,7 @@ let rec tree_of_typexp sch ty =
         pr_arrow l ty1 ty2
     | Ttuple tyl ->
         Otyp_tuple (tree_of_typlist sch tyl)
-    | Tconstr(p, tyl, abbrev) ->
+    | Tconstr(p, tyl, _abbrev) ->
         let p', s = best_type_path p in
         let tyl' = apply_subst s tyl in
         if is_nth s then tree_of_typexp sch (List.hd tyl') else
@@ -687,7 +689,8 @@ and tree_of_typobject sch fi nm =
                | _ -> l)
             fields [] in
         let sorted_fields =
-          List.sort (fun (n, _) (n', _) -> compare n n') present_fields in
+          List.sort
+            (fun (n, _) (n', _) -> String.compare n n') present_fields in
         tree_of_typfields sch rest sorted_fields in
       let (fields, rest) = pr_fields fi in
       Otyp_object (fields, rest)
@@ -719,19 +722,19 @@ and tree_of_typfields sch rest = function
       let (fields, rest) = tree_of_typfields sch rest l in
       (field :: fields, rest)
 
-let typexp sch prio ppf ty =
+let typexp sch ppf ty =
   !Oprint.out_type ppf (tree_of_typexp sch ty)
 
-let type_expr ppf ty = typexp false 0 ppf ty
+let type_expr ppf ty = typexp false ppf ty
 
-and type_sch ppf ty = typexp true 0 ppf ty
+and type_sch ppf ty = typexp true ppf ty
 
-and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty
+and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
 
 (* Maxence *)
 let type_scheme_max ?(b_reset_names=true) ppf ty =
   if b_reset_names then reset_names () ;
-  typexp true 0 ppf ty
+  typexp true ppf ty
 (* End Maxence *)
 
 let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty
@@ -808,7 +811,7 @@ let rec tree_of_type_decl id decl =
            mark_loops_constructor_arguments c.cd_args;
            may mark_loops c.cd_res)
         cstrs
-  | Type_record(l, rep) ->
+  | Type_record(l, _rep) ->
       List.iter (fun l -> mark_loops l.ld_type) l
   | Type_open -> ()
   end;
@@ -860,7 +863,7 @@ let rec tree_of_type_decl id decl =
     | Type_variant cstrs ->
         tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
         decl.type_private
-    | Type_record(lbls, rep) ->
+    | Type_record(lbls, _rep) ->
         tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
         decl.type_private
     | Type_open ->
@@ -868,13 +871,14 @@ let rec tree_of_type_decl id decl =
         Public
   in
   let immediate =
-    List.exists (fun (loc, _) -> loc.txt = "immediate") decl.type_attributes
+    Builtin_attributes.immediate decl.type_attributes
   in
     { otype_name = name;
       otype_params = args;
       otype_type = ty;
       otype_private = priv;
       otype_immediate = immediate;
+      otype_unboxed = decl.type_unboxed.unboxed;
       otype_cstrs = constraints }
 
 and tree_of_constructor_arguments = function
@@ -999,7 +1003,7 @@ let tree_of_metho sch concrete csil (lab, kind, ty) =
   else csil
 
 let rec prepare_class_type params = function
-  | Cty_constr (p, tyl, cty) ->
+  | Cty_constr (_p, tyl, cty) ->
       let sty = Ctype.self_type cty in
       if List.memq (proxy sty) !visited_objects
       || not (List.for_all is_Tvar params)
@@ -1130,7 +1134,7 @@ let tree_of_cltype_declaration id cl rs =
     let (fields, _) =
       Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in
     List.exists
-      (fun (lab, _, ty) ->
+      (fun (lab, _, _) ->
          not (lab = dummy_method || Concr.mem lab sign.csig_concr))
       fields
     || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false
@@ -1169,10 +1173,11 @@ let dummy =
     type_newtype_level = None; type_loc = Location.none;
     type_attributes = [];
     type_immediate = false;
+    type_unboxed = unboxed_false_default_false;
   }
 
 let hide_rec_items = function
-  | Sig_type(id, decl, rs) ::rem
+  | Sig_type(id, _decl, rs) ::rem
     when rs = Trec_first && not !Clflags.real_paths ->
       let rec get_ids = function
           Sig_type (id, _, Trec_next) :: rem ->
@@ -1201,7 +1206,7 @@ let rec tree_of_modtype ?(ellipsis=false) = function
       in
       Omty_functor (Ident.name param,
                     may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
-  | Mty_alias p ->
+  | Mty_alias(_, p) ->
       Omty_alias (tree_of_path p)
 
 and tree_of_signature sg =
@@ -1264,7 +1269,7 @@ let modtype_declaration id ppf decl =
 let rec print_items showval env = function
   | [] -> []
   | item :: rem as items ->
-      let (sg, rem) = filter_rem_sig item rem in
+      let (_sg, rem) = filter_rem_sig item rem in
       hide_rec_items items;
       let trees = trees_of_sigitem item in
       List.map (fun d -> (d, showval env item)) trees @
@@ -1362,7 +1367,7 @@ let print_tags ppf fields =
       fprintf ppf "`%s" t;
       List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields
 
-let has_explanation unif t3 t4 =
+let has_explanation t3 t4 =
   match t3.desc, t4.desc with
     Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
   | Tnil, Tconstr _ | Tconstr _, Tnil
@@ -1371,12 +1376,12 @@ let has_explanation unif t3 t4 =
   | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
   | _ -> false
 
-let rec mismatch unif = function
+let rec mismatch = function
     (_, t) :: (_, t') :: rem ->
-      begin match mismatch unif rem with
+      begin match mismatch rem with
         Some _ as m -> m
       | None ->
-          if has_explanation unif t t' then Some(t,t') else None
+          if has_explanation t t' then Some(t,t') else None
       end
   | [] -> None
   | _ -> assert false
@@ -1385,12 +1390,12 @@ let explanation unif t3 t4 ppf =
   match t3.desc, t4.desc with
   | Ttuple [], Tvar _ | Tvar _, Ttuple [] ->
       fprintf ppf "@,Self type cannot escape its class"
-  | Tconstr (p, tl, _), Tvar _
+  | Tconstr (p, _, _), Tvar _
     when unif && t4.level < Path.binding_time p ->
       fprintf ppf
         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
         path p
-  | Tvar _, Tconstr (p, tl, _)
+  | Tvar _, Tconstr (p, _, _)
     when unif && t3.level < Path.binding_time p ->
       fprintf ppf
         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
@@ -1492,7 +1497,7 @@ let unification_error env unif tr txt1 ppf txt2 =
   reset ();
   trace_same_names tr;
   let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
-  let mis = mismatch unif tr in
+  let mis = mismatch tr in
   match tr with
   | [] | _ :: [] -> assert false
   | t1 :: t2 :: tr ->
@@ -1547,7 +1552,7 @@ let report_subtyping_error ppf env tr1 txt1 tr2 =
     and tr2 = List.map prepare_expansion tr2 in
     fprintf ppf "@[<v>%a" (trace true (tr2 = []) txt1) tr1;
     if tr2 = [] then fprintf ppf "@]" else
-    let mis = mismatch true tr2 in
+    let mis = mismatch tr2 in
     fprintf ppf "%a%t@]"
       (trace false (mis = None) "is not compatible with type") tr2
       (explanation true mis))

diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index a0cf628233f907a57ed2ac55aa28c2747aeca1ca..410cc1c9f0c898d85beb6275080c7b713ef9cf1f 100644 (file)
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -121,6 +121,16 @@ let list i f ppf l =
      line i ppf "]\n";
 ;;
 
+let array i f ppf a =
+  if Array.length a = 0 then
+    line i ppf "[]\n"
+  else begin
+    line i ppf "[\n";
+    Array.iter (f (i+1) ppf) a;
+    line i ppf "]\n"
+  end
+;;
+
 let option i f ppf x =
   match x with
   | None -> line i ppf "None\n";
@@ -214,6 +224,10 @@ and pattern i ppf x =
         line i ppf "Tpat_type %a\n" fmt_path id;
         attributes i ppf attrs;
         pattern i ppf { x with pat_extra = rem }
+    | (Tpat_open (id,_,_), _, attrs)::rem ->
+        line i ppf "Tpat_open \"%a\"\n" fmt_path id;
+        attributes i ppf attrs;
+        pattern i ppf { x with pat_extra = rem }
     | [] ->
   match x.pat_desc with
   | Tpat_any -> line i ppf "Tpat_any\n";
@@ -231,7 +245,7 @@ and pattern i ppf x =
   | Tpat_variant (l, po, _) ->
       line i ppf "Tpat_variant \"%s\"\n" l;
       option i pattern ppf po;
-  | Tpat_record (l, c) ->
+  | Tpat_record (l, _c) ->
       line i ppf "Tpat_record\n";
       list i longident_x_pattern ppf l;
   | Tpat_array (l) ->
@@ -291,7 +305,7 @@ and expression i ppf x =
       line i ppf "Texp_apply\n";
       expression i ppf e;
       list i label_x_expression ppf l;
-  | Texp_match (e, l1, l2, partial) ->
+  | Texp_match (e, l1, l2, _partial) ->
       line i ppf "Texp_match\n";
       expression i ppf e;
       list i case ppf l1;
@@ -309,10 +323,10 @@ and expression i ppf x =
   | Texp_variant (l, eo) ->
       line i ppf "Texp_variant \"%s\"\n" l;
       option i expression ppf eo;
-  | Texp_record (l, eo) ->
+  | Texp_record { fields; extended_expression; _ } ->
       line i ppf "Texp_record\n";
-      list i longident_x_expression ppf l;
-      option i expression ppf eo;
+      array i record_field ppf fields;
+      option i expression ppf extended_expression;
   | Texp_field (e, li, _) ->
       line i ppf "Texp_field\n";
       expression i ppf e;
@@ -362,6 +376,10 @@ and expression i ppf x =
       line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
       module_expr i ppf me;
       expression i ppf e;
+  | Texp_letexception (cd, e) ->
+      line i ppf "Pexp_letexception\n";
+      extension_constructor i ppf cd;
+      expression i ppf e;
   | Texp_assert (e) ->
       line i ppf "Texp_assert";
       expression i ppf e;
@@ -819,9 +837,12 @@ and string_x_expression i ppf (s, _, e) =
   line i ppf "<override> \"%a\"\n" fmt_path s;
   expression (i+1) ppf e;
 
-and longident_x_expression i ppf (li, _, e) =
-  line i ppf "%a\n" fmt_longident li;
-  expression (i+1) ppf e;
+and record_field i ppf = function
+  | _, Overridden (li, e) ->
+      line i ppf "%a\n" fmt_longident li;
+      expression (i+1) ppf e;
+  | _, Kept _ ->
+      line i ppf "<kept>"
 
 and label_x_expression i ppf (l, e) =
   line i ppf "<arg>\n";

diff --git a/typing/stypes.ml b/typing/stypes.ml
index 8a3e1096af5ec58cc07f060efedcbbc8d8005e8f..140b79e2fef8132750c2c4658fca08725e3469f1 100644 (file)
--- a/typing/stypes.ml
+++ b/typing/stypes.ml
@@ -44,8 +44,8 @@ let get_location ti =
   | Ti_expr e  -> e.exp_loc
   | Ti_class c -> c.cl_loc
   | Ti_mod m   -> m.mod_loc
-  | An_call (l, k) -> l
-  | An_ident (l, s, k) -> l
+  | An_call (l, _k) -> l
+  | An_ident (l, _s, _k) -> l
 ;;
 
 let annotations = ref ([] : annotation list);;

diff --git a/typing/subst.ml b/typing/subst.ml
index 5ea5260e622c49719ae9eae060602f1cbe51540d..85da130bf6a26cb3adbfcba940f6464b08f2cfa9 100644 (file)
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -82,7 +82,7 @@ let modtype_path s = function
       with Not_found -> p end
   | Pdot(p, n, pos) ->
       Pdot(module_path s p, n, pos)
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Subst.modtype_path"
 
 let type_path s = function
@@ -90,7 +90,7 @@ let type_path s = function
       begin try Tbl.find id s.types with Not_found -> p end
   | Pdot(p, n, pos) ->
       Pdot(module_path s p, n, pos)
-  | Papply(p1, p2) ->
+  | Papply _ ->
       fatal_error "Subst.type_path"
 
 let type_path s p =
@@ -135,6 +135,10 @@ let rec typexp s ty =
       end
   | Tsubst ty ->
       ty
+  | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method
+      && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
+      (* do not copy the type of self when it is not generalized *)
+      ty
 (* cannot do it, since it would omit subsitution
   | Tvariant row when not (static_row row) ->
       ty
@@ -147,7 +151,7 @@ let rec typexp s ty =
     ty.desc <- Tsubst ty';
     ty'.desc <-
       begin match desc with
-      | Tconstr(p, tl, abbrev) ->
+      | Tconstr(p, tl, _abbrev) ->
           Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
       | Tpackage(p, n, tl) ->
           Tpackage(modtype_path s p, n, List.map (typexp s) tl)
@@ -157,10 +161,6 @@ let rec typexp s ty =
                         None -> None
                       | Some (p, tl) ->
                           Some (type_path s p, List.map (typexp s) tl)))
-      | Tfield (m, k, t1, t2)
-        when s == identity && ty.level < generic_level && m = dummy_method ->
-          (* not allowed to lower the level of the dummy method *)
-          Tfield (m, k, t1, typexp s t2)
       | Tvariant row ->
           let row = row_repr row in
           let more = repr row.row_more in
@@ -197,7 +197,7 @@ let rec typexp s ty =
               | None ->
                   Tvariant row
           end
-      | Tfield(label, kind, t1, t2) when field_kind_repr kind = Fabsent ->
+      | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent ->
           Tlink (typexp s t2)
       | _ -> copy_type_desc (typexp s) desc
       end;
@@ -261,6 +261,7 @@ let type_declaration s decl =
       type_loc = loc s decl.type_loc;
       type_attributes = attrs s decl.type_attributes;
       type_immediate = decl.type_immediate;
+      type_unboxed = decl.type_unboxed;
     }
   in
   cleanup_types ();
@@ -345,13 +346,13 @@ let extension_constructor s ext =
 
 let rec rename_bound_idents s idents = function
     [] -> (List.rev idents, s)
-  | Sig_type(id, d, _) :: sg ->
+  | Sig_type(id, _, _) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
-  | Sig_module(id, mty, _) :: sg ->
+  | Sig_module(id, _, _) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg
-  | Sig_modtype(id, d) :: sg ->
+  | Sig_modtype(id, _) :: sg ->
       let id' = Ident.rename id in
       rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s)
                           (id' :: idents) sg
@@ -370,7 +371,7 @@ let rec modtype s = function
           begin try Tbl.find id s.modtypes with Not_found -> mty end
       | Pdot(p, n, pos) ->
           Mty_ident(Pdot(module_path s p, n, pos))
-      | Papply(p1, p2) ->
+      | Papply _ ->
           fatal_error "Subst.modtype"
       end
   | Mty_signature sg ->
@@ -379,8 +380,8 @@ let rec modtype s = function
       let id' = Ident.rename id in
       Mty_functor(id', may_map (modtype s) arg,
                        modtype (add_module id (Pident id') s) res)
-  | Mty_alias p ->
-      Mty_alias(module_path s p)
+  | Mty_alias(pres, p) ->
+      Mty_alias(pres, module_path s p)
 
 and signature s sg =
   (* Components of signature may be mutually recursive (e.g. type declarations
@@ -392,19 +393,19 @@ and signature s sg =
 
 and signature_component s comp newid =
   match comp with
-    Sig_value(id, d) ->
+    Sig_value(_id, d) ->
       Sig_value(newid, value_description s d)
-  | Sig_type(id, d, rs) ->
+  | Sig_type(_id, d, rs) ->
       Sig_type(newid, type_declaration s d, rs)
-  | Sig_typext(id, ext, es) ->
+  | Sig_typext(_id, ext, es) ->
       Sig_typext(newid, extension_constructor s ext, es)
-  | Sig_module(id, d, rs) ->
+  | Sig_module(_id, d, rs) ->
       Sig_module(newid, module_declaration s d, rs)
-  | Sig_modtype(id, d) ->
+  | Sig_modtype(_id, d) ->
       Sig_modtype(newid, modtype_declaration s d)
-  | Sig_class(id, d, rs) ->
+  | Sig_class(_id, d, rs) ->
       Sig_class(newid, class_declaration s d, rs)
-  | Sig_class_type(id, d, rs) ->
+  | Sig_class_type(_id, d, rs) ->
       Sig_class_type(newid, cltype_declaration s d, rs)
 
 and module_declaration s decl =

diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
index 66127d50f36113e5f34dcf9ce212eb72d5663190..e77299cefbf8eeb9ab38bd40b74877504b4cacf0 100644 (file)
--- a/typing/tast_mapper.ml
+++ b/typing/tast_mapper.ml
@@ -186,6 +186,7 @@ let pat sub x =
   let extra = function
     | Tpat_type _
     | Tpat_unpack as d -> d
+    | Tpat_open (path,loc,env) ->  Tpat_open (path, loc, sub.env sub env)
     | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct)
   in
   let pat_env = sub.env sub x.pat_env in
@@ -254,11 +255,17 @@ let expr sub x =
         Texp_construct (lid, cd, List.map (sub.expr sub) args)
     | Texp_variant (l, expo) ->
         Texp_variant (l, opt (sub.expr sub) expo)
-    | Texp_record (list, expo) ->
-        Texp_record (
-          List.map (tuple3 id id (sub.expr sub)) list,
-          opt (sub.expr sub) expo
-        )
+    | Texp_record { fields; representation; extended_expression } ->
+        let fields = Array.map (function
+            | label, Kept t -> label, Kept t
+            | label, Overridden (lid, exp) ->
+                label, Overridden (lid, sub.expr sub exp))
+            fields
+        in
+        Texp_record {
+          fields; representation;
+          extended_expression = opt (sub.expr sub) extended_expression;
+        }
     | Texp_field (exp, lid, ld) ->
         Texp_field (sub.expr sub exp, lid, ld)
     | Texp_setfield (exp1, lid, ld, exp2) ->
@@ -323,6 +330,11 @@ let expr sub x =
           sub.module_expr sub mexpr,
           sub.expr sub exp
         )
+    | Texp_letexception (cd, exp) ->
+        Texp_letexception (
+          sub.extension_constructor sub cd,
+          sub.expr sub exp
+        )
     | Texp_assert exp ->
         Texp_assert (sub.expr sub exp)
     | Texp_lazy exp ->

diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 884fdfe58cfb4a320bce9d9bd0385145d663f8b0..daaeab47b0afefaedef6824e028f731177234355 100644 (file)
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -21,6 +21,32 @@ open Typecore
 open Typetexp
 open Format
 
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
 type error =
     Unconsistent_constraint of (type_expr * type_expr) list
   | Field_type_mismatch of string * string * (type_expr * type_expr) list
@@ -123,18 +149,18 @@ let rec constructor_type constr cty =
   match cty with
     Cty_constr (_, _, cty) ->
       constructor_type constr cty
-  | Cty_signature sign ->
+  | Cty_signature _ ->
       constr
   | Cty_arrow (l, ty, cty) ->
       Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
 
 let rec class_body cty =
   match cty with
-    Cty_constr (_, _, cty') ->
+    Cty_constr _ ->
       cty (* Only class bodies can be abbreviated *)
-  | Cty_signature sign ->
+  | Cty_signature _ ->
       cty
-  | Cty_arrow (_, ty, cty) ->
+  | Cty_arrow (_, _, cty) ->
       class_body cty
 
 let extract_constraints cty =
@@ -182,7 +208,7 @@ let closed_class cty =
 
 let rec limited_generalize rv =
   function
-    Cty_constr (path, params, cty) ->
+    Cty_constr (_path, params, cty) ->
       List.iter (Ctype.limited_generalize rv) params;
       limited_generalize rv cty
   | Cty_signature sign ->
@@ -365,10 +391,10 @@ let make_method loc cl_num expr =
 
 (*******************************)
 
-let add_val env loc lab (mut, virt, ty) val_sig =
+let add_val lab (mut, virt, ty) val_sig =
   let virt =
     try
-      let (mut', virt', ty') = Vars.find lab val_sig in
+      let (_mut', virt', _ty') = Vars.find lab val_sig in
       if virt' = Concrete then virt' else virt
     with Not_found -> virt
   in
@@ -393,7 +419,7 @@ let rec class_type_field env self_type meths
           parent.cltyp_type
       in
       let val_sig =
-        Vars.fold (add_val env sparent.pcty_loc) cl_sig.csig_vars val_sig in
+        Vars.fold add_val cl_sig.csig_vars val_sig in
       (mkctf (Tctf_inherit parent) :: fields,
        val_sig, concr_meths, inher)
 
@@ -401,7 +427,7 @@ let rec class_type_field env self_type meths
       let cty = transl_simple_type env false sty in
       let ty = cty.ctyp_type in
       (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
-      add_val env ctf.pctf_loc lab (mut, virt, ty) val_sig, concr_meths, inher)
+      add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
 
   | Pctf_method (lab, priv, virt, sty)  ->
       let cty =
@@ -569,7 +595,7 @@ let rec class_field self_loc cl_num self_type meths vars
           None ->
             (val_env, met_env, par_env)
         | Some name ->
-            let (id, val_env, met_env, par_env) =
+            let (_id, val_env, met_env, par_env) =
               enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
                 sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type
                 val_env met_env par_env
@@ -790,7 +816,7 @@ and class_structure cl_num final val_env met_env loc
   Ctype.unify val_env self_type (Ctype.newvar ());
   let sign =
     {csig_self = public_self;
-     csig_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+     csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
      csig_concr = concr_meths;
       csig_inher = inher} in
   let methods = get_methods self_type in
@@ -804,7 +830,7 @@ and class_structure cl_num final val_env met_env loc
     let mets = virtual_methods {sign with csig_self = self_type} in
     let vals =
       Vars.fold
-        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
         sign.csig_vars [] in
     if mets <> [] || vals <> [] then
       raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
@@ -838,7 +864,7 @@ and class_structure cl_num final val_env met_env loc
     Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
   end;
   let fields = List.map Lazy.force (List.rev fields) in
-  let meths = Meths.map (function (id, ty) -> id) !meths in
+  let meths = Meths.map (function (id, _ty) -> id) !meths in
 
   (* Check for private methods made public *)
   let pub_meths' =
@@ -946,7 +972,7 @@ and class_expr cl_num val_env met_env scl =
       end;
       let pv =
         List.map
-          begin fun (id, id_loc, id', ty) ->
+          begin fun (id, id_loc, id', _ty) ->
             let path = Pident id' in
             (* do not mark the value as being used *)
             let vd = Env.find_value path val_env' in
@@ -1217,6 +1243,7 @@ let temp_abbrev loc env id arity =
        type_loc = loc;
        type_attributes = []; (* or keep attrs from the class decl? *)
        type_immediate = false;
+       type_unboxed = unboxed_false_default_false;
       }
       env
   in
@@ -1415,7 +1442,7 @@ let class_infos define_class kind
     let mets = virtual_methods sign in
     let vals =
       Vars.fold
-        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
+        (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
         sign.csig_vars [] in
     if mets <> []  || vals <> [] then
       raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
@@ -1464,6 +1491,7 @@ let class_infos define_class kind
      type_loc = cl.pci_loc;
      type_attributes = []; (* or keep attrs from cl? *)
      type_immediate = false;
+     type_unboxed = unboxed_false_default_false;
     }
   in
   let (cl_params, cl_ty) =
@@ -1482,6 +1510,7 @@ let class_infos define_class kind
      type_loc = cl.pci_loc;
      type_attributes = []; (* or keep attrs from cl? *)
      type_immediate = false;
+     type_unboxed = unboxed_false_default_false;
     }
   in
   ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
@@ -1532,7 +1561,7 @@ let final_decl env define_class
      ci_id_class = id;
      ci_id_class_type = ty_id;
      ci_id_object = obj_id;
-     ci_id_typesharp = cl_id;
+     ci_id_typehash = cl_id;
      ci_expr = expr;
      ci_decl = clty;
      ci_type_decl = cltydef;
@@ -1541,8 +1570,8 @@ let final_decl env define_class
 (*   (cl.pci_variance, cl.pci_loc)) *)
 
 let extract_type_decls
-    (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, coe, expr, required) decls =
+    (_id, _id_loc, clty, _ty_id, cltydef, obj_id, obj_abbr, _cl_id, cl_abbr,
+     _arity, _pub_meths, _coe, _expr, required) decls =
   (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls
 
 let merge_type_decls
@@ -1552,8 +1581,8 @@ let merge_type_decls
    arity, pub_meths, coe, expr, req)
 
 let final_env define_class env
-    (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, coe, expr, req) =
+    (id, _id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+     _arity, _pub_meths, _coe, _expr, _req) =
   (* Add definitions after cleaning them *)
   Env.add_type ~check:true obj_id
     (Subst.type_declaration Subst.identity obj_abbr) (
@@ -1567,7 +1596,7 @@ let final_env define_class env
 (* Check that #c is coercible to c if there is a self-coercion *)
 let check_coercions env
     (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-     arity, pub_meths, coercion_locs, expr, req) =
+     arity, pub_meths, coercion_locs, _expr, req) =
   begin match coercion_locs with [] -> ()
   | loc :: _ ->
       let cl_ty, obj_ty =
@@ -1589,8 +1618,18 @@ let check_coercions env
       if not (Ctype.opened_object cl_ty) then
         raise(Error(loc, env, Cannot_coerce_self obj_ty))
   end;
-  (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-   arity, pub_meths, req)
+  {cls_id = id;
+   cls_id_loc = id_loc;
+   cls_decl = clty;
+   cls_ty_id = ty_id;
+   cls_ty_decl = cltydef;
+   cls_obj_id = obj_id;
+   cls_obj_abbr = obj_abbr;
+   cls_typesharp_id = cl_id;
+   cls_abbr = cl_abbr;
+   cls_arity = arity;
+   cls_pub_methods = pub_meths;
+   cls_info=req}
 
 (*******************************)
 
@@ -1637,15 +1676,20 @@ let class_descriptions env cls =
   type_classes true approx_description class_description env cls
 
 let class_type_declarations env cls =
-  let (decl, env) =
+  let (decls, env) =
     type_classes false approx_description class_description env cls
   in
   (List.map
-     (function
-       (_, id_loc, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
-        _, _, ci) ->
-       (ty_id, id_loc, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci))
-     decl,
+     (fun decl ->
+        {clsty_ty_id = decl.cls_ty_id;
+         clsty_id_loc = decl.cls_id_loc;
+         clsty_ty_decl = decl.cls_ty_decl;
+         clsty_obj_id = decl.cls_obj_id;
+         clsty_obj_abbr = decl.cls_obj_abbr;
+         clsty_typesharp_id = decl.cls_typesharp_id;
+         clsty_abbr = decl.cls_abbr;
+         clsty_info = decl.cls_info})
+     decls,
    env)
 
 let rec unify_parents env ty cl =
@@ -1657,7 +1701,7 @@ let rec unify_parents env ty cl =
         Ctype.unify env ty (Ctype.instance env body)
       with
         Not_found -> ()
-      | exn -> assert false
+      | _exn -> assert false
       end
   | Tcl_structure st -> unify_parents_struct env ty st
   | Tcl_fun (_, _, _, cl, _)
@@ -1722,7 +1766,7 @@ let report_error env ppf = function
       fprintf ppf
         "@[This class expression is not a class structure; it has type@ %a@]"
         Printtyp.class_type clty
-  | Cannot_apply clty ->
+  | Cannot_apply _ ->
       fprintf ppf
         "This class expression is not a class function, it cannot be applied"
   | Apply_wrong_label l ->
@@ -1846,7 +1890,7 @@ let report_error env ppf = function
            fprintf ppf "This object is expected to have type")
         (function ppf ->
            fprintf ppf "but actually has type")
-  | Mutability_mismatch (lab, mut) ->
+  | Mutability_mismatch (_lab, mut) ->
       let mut1, mut2 =
         if mut = Immutable then "mutable", "immutable"
         else "immutable", "mutable" in

diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index b6157be18c6d6c1af336a0e6ac5722bf6b2a0f81..1735bf9e9a8de9302510d606a533c54d8c0786de 100644 (file)
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -17,13 +17,35 @@ open Asttypes
 open Types
 open Format
 
+type 'a class_info = {
+  cls_id : Ident.t;
+  cls_id_loc : string loc;
+  cls_decl : class_declaration;
+  cls_ty_id : Ident.t;
+  cls_ty_decl : class_type_declaration;
+  cls_obj_id : Ident.t;
+  cls_obj_abbr : type_declaration;
+  cls_typesharp_id : Ident.t;
+  cls_abbr : type_declaration;
+  cls_arity : int;
+  cls_pub_methods : string list;
+  cls_info : 'a;
+}
+
+type class_type_info = {
+  clsty_ty_id : Ident.t;
+  clsty_id_loc : string loc;
+  clsty_ty_decl : class_type_declaration;
+  clsty_obj_id : Ident.t;
+  clsty_obj_abbr : type_declaration;
+  clsty_typesharp_id : Ident.t;
+  clsty_abbr : type_declaration;
+  clsty_info : Typedtree.class_type_declaration;
+}
+
 val class_declarations:
   Env.t -> Parsetree.class_declaration list ->
-  (Ident.t * string loc * class_declaration *
-   Ident.t * class_type_declaration *
-   Ident.t * type_declaration *
-   Ident.t * type_declaration *
-   int * string list * Typedtree.class_declaration) list * Env.t
+  Typedtree.class_declaration class_info list * Env.t
 
 (*
 and class_declaration =
@@ -32,11 +54,7 @@ and class_declaration =
 
 val class_descriptions:
   Env.t -> Parsetree.class_description list ->
-  (Ident.t * string loc * class_declaration *
-   Ident.t * class_type_declaration *
-   Ident.t * type_declaration *
-   Ident.t * type_declaration *
-   int * string list * Typedtree.class_description) list * Env.t
+  Typedtree.class_description class_info list * Env.t
 
 (*
 and class_description =
@@ -44,11 +62,7 @@ and class_description =
 *)
 
 val class_type_declarations:
-  Env.t -> Parsetree.class_description list ->
-  (Ident.t * string loc * class_type_declaration *
-   Ident.t * type_declaration *
-   Ident.t * type_declaration *
-  Typedtree.class_type_declaration) list * Env.t
+  Env.t -> Parsetree.class_description list -> class_type_info list * Env.t
 
 (*
 and class_type_declaration =
@@ -56,11 +70,7 @@ and class_type_declaration =
 *)
 
 val approx_class_declarations:
-  Env.t -> Parsetree.class_description list ->
-  (Ident.t * string loc * class_type_declaration *
-   Ident.t * type_declaration *
-   Ident.t * type_declaration *
-  Typedtree.class_type_declaration) list
+  Env.t -> Parsetree.class_description list -> class_type_info list
 
 val virtual_methods: Types.class_signature -> label list
 

diff --git a/typing/typecore.ml b/typing/typecore.ml
index dd355320f99d94ee0ccb1b8bdf5f34f69abe55fa..116dc1b96baad74e9b26f48adafce70b27fda58b 100644 (file)
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -84,7 +84,7 @@ exception Error_forward of Location.error
 (* Forward declaration, to be filled in by Typemod.type_module *)
 
 let type_module =
-  ref ((fun env md -> assert false) :
+  ref ((fun _env _md -> assert false) :
        Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
 
 (* Forward declaration, to be filled in by Typemod.type_open *)
@@ -99,7 +99,7 @@ let type_package =
 
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 let type_object =
-  ref (fun env s -> assert false :
+  ref (fun _env _s -> assert false :
        Env.t -> Location.t -> Parsetree.class_structure ->
          Typedtree.class_structure * Types.class_signature * string list)
 
@@ -162,6 +162,7 @@ let iter_expression f e =
     | Pexp_send (e, _)
     | Pexp_constraint (e, _)
     | Pexp_coerce (e, _, _)
+    | Pexp_letexception (_, e)
     | Pexp_field (e, _) -> expr e
     | Pexp_while (e1, e2)
     | Pexp_sequence (e1, e2)
@@ -332,7 +333,7 @@ let extract_concrete_variant env ty =
   | (p0, p, {type_kind=Type_open}) -> (p0, p, [])
   | _ -> raise Not_found
 
-let extract_label_names sexp env ty =
+let extract_label_names env ty =
   try
     let (_, _,fields) = extract_concrete_record env ty in
     List.map (fun l -> l.Types.ld_id) fields
@@ -410,7 +411,7 @@ let finalize_variant pat =
           begin match opat with None -> assert false
           | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
           end
-      | Reither (c, l, true, e) when not (row_fixed row) ->
+      | Reither (c, _l, true, e) when not (row_fixed row) ->
           set_row_field e (Reither (c, [], false, ref None))
       | _ -> ()
       end;
@@ -481,7 +482,8 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
   let rec unify_vars p1_vs p2_vs =
     let vars vs = List.map (fun (x,_t,_,_l,_a) -> x) vs in
     match p1_vs, p2_vs with
-      | (x1,t1,_,l1,a1)::rem1, (x2,t2,_,l2,a2)::rem2 when Ident.equal x1 x2 ->
+      | (x1,t1,_,_l1,_a1)::rem1, (x2,t2,_,_l2,_a2)::rem2
+        when Ident.equal x1 x2 ->
           if x1==x2 then
             unify_vars rem1 rem2
           else begin
@@ -641,7 +643,7 @@ module NameChoice(Name : sig
 end) = struct
   open Name
 
-  let get_type_path env d =
+  let get_type_path d =
     match (repr (get_type d)).desc with
     | Tconstr(p, _, _) -> p
     | _ -> assert false
@@ -667,9 +669,9 @@ end) = struct
         else unique eq (x :: acc) rem
 
   let ambiguous_types env lbl others =
-    let tpath = get_type_path env lbl in
+    let tpath = get_type_path lbl in
     let others =
-      List.map (fun (lbl, _) -> get_type_path env lbl) others in
+      List.map (fun (lbl, _) -> get_type_path lbl) others in
     let tpaths = unique (compare_type_path env) [tpath] others in
     match tpaths with
       [_] -> []
@@ -677,7 +679,7 @@ end) = struct
 
   let disambiguate_by_type env tpath lbls =
     let check_type (lbl, _) =
-      let lbl_tpath = get_type_path env lbl in
+      let lbl_tpath = get_type_path lbl in
       compare_type_path env tpath lbl_tpath
     in
     List.find check_type lbls
@@ -712,8 +714,8 @@ end) = struct
             (* Check if non-principal type is affecting result *)
             match lbls with
               [] -> warn_pr ()
-            | (lbl', use') :: rest ->
-                let lbl_tpath = get_type_path env lbl' in
+            | (lbl', _use') :: rest ->
+                let lbl_tpath = get_type_path lbl' in
                 if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
                 else
                   let paths = ambiguous_types env lbl rest in
@@ -740,7 +742,7 @@ end) = struct
           let tpl =
             List.map
               (fun (lbl, _) ->
-                let tp0 = get_type_path env lbl in
+                let tp0 = get_type_path lbl in
                 let tp = expand_path env tp0 in
                   (tp0, tp))
               lbls
@@ -771,11 +773,11 @@ module Label = NameChoice (struct
   let unbound_name_error = Typetexp.unbound_label_error
   let in_env lbl =
     match lbl.lbl_repres with
-    | Record_regular | Record_float -> true
-    | Record_inlined _ | Record_extension -> false
+    | Record_regular | Record_float | Record_unboxed false -> true
+    | Record_unboxed true | Record_inlined _ | Record_extension -> false
 end)
 
-let disambiguate_label_by_ids keep env closed ids labels =
+let disambiguate_label_by_ids keep closed ids labels =
   let check_ids (lbl, _) =
     let lbls = Hashtbl.create 8 in
     Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
@@ -819,7 +821,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
     let (ok, labels) =
       match opath with
         Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *)
-      | _  -> disambiguate_label_by_ids (opath=None) env closed ids scope
+      | _  -> disambiguate_label_by_ids (opath=None) closed ids scope
     in
     if ok then Label.disambiguate lid env opath labels ~warn ~scope
           else fst (List.hd labels) (* will fail later *)
@@ -831,9 +833,9 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
       (Warnings.Not_principal "this type-based record disambiguation")
   else begin
     match List.rev !w_amb with
-      (_,types)::others as amb ->
+      (_,types)::_ as amb ->
         let paths =
-          List.map (fun (_,lbl,_) -> Label.get_type_path env lbl) lbl_a_list in
+          List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
         let path = List.hd paths in
         if List.for_all (compare_type_path env path) (List.tl paths) then
           Location.prerr_warning loc
@@ -1004,8 +1006,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
           ~explode sp expected_ty k
       else k' Tpat_any
   | Ppat_var name ->
-      assert (constrs = None);
-      let id = enter_variable loc name expected_ty in
+      let id = (* PR#7330 *)
+        if name.txt = "*extension*" then Ident.create name.txt else
+        enter_variable loc name expected_ty
+      in
       rp k {
         pat_desc = Tpat_var (id, name);
         pat_loc = loc; pat_extra=[];
@@ -1264,7 +1268,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
       unify_pat_types
         loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
       let spl_ann = List.map (fun p -> (p,newvar())) spl in
-      map_fold_cont (fun (p,t) -> type_pat p ty_elt) spl_ann (fun pl ->
+      map_fold_cont (fun (p,_) -> type_pat p ty_elt) spl_ann (fun pl ->
         rp k {
         pat_desc = Tpat_array pl;
         pat_loc = loc; pat_extra=[];
@@ -1360,6 +1364,15 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
       unify_pat_types loc !env ty expected_ty;
       k { p with pat_extra =
         (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
+  | Ppat_open (lid,p) ->
+      let path, new_env =
+        !type_open Asttypes.Fresh !env sp.ppat_loc lid in
+      let new_env = ref new_env in
+      type_pat ~env:new_env p expected_ty ( fun p ->
+        env := Env.copy_local !env ~from:!new_env;
+        k { p with pat_extra =( Tpat_open (path,lid,!new_env),
+                            loc, sp.ppat_attributes) :: p.pat_extra }
+      )
   | Ppat_exception _ ->
       raise (Error (loc, !env, Exception_pattern_below_toplevel))
   | Ppat_extension ext ->
@@ -1388,8 +1401,10 @@ let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p =
   try
     reset_pattern None true;
     let typed_p =
-      type_pat ~allow_existentials:true ~lev
-        ~constrs ~labels ?mode ?explode env p expected_ty
+      Ctype.with_passive_variants
+        (type_pat ~allow_existentials:true ~lev
+           ~constrs ~labels ?mode ?explode env p)
+        expected_ty
     in
     set_state state env;
     (* types are invalidated but we don't need them here *)
@@ -1413,12 +1428,12 @@ let check_unused ?(lev=get_current_level ()) env expected_ty cases =
         Some pat when refute ->
           raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat))
       | r -> r)
-    env cases
+    cases
 
 let add_pattern_variables ?check ?check_as env =
   let pv = get_ref pattern_variables in
   (List.fold_right
-     (fun (id, ty, name, loc, as_var) env ->
+     (fun (id, ty, _name, loc, as_var) env ->
        let check = if as_var then check_as else check in
        Env.add_value ?check id
          {val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
@@ -1490,7 +1505,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
   pattern_variables := [];
   let (val_env, met_env, par_env) =
     List.fold_right
-      (fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) ->
+      (fun (id, ty, _name, loc, as_var) (val_env, met_env, par_env) ->
          (Env.add_value id {val_type = ty;
                             val_kind = Val_unbound;
                             val_attributes = [];
@@ -1544,7 +1559,7 @@ let rec is_nonexpansive exp =
   match exp.exp_desc with
     Texp_ident(_,_,_) -> true
   | Texp_constant _ -> true
-  | Texp_let(rec_flag, pat_exp_list, body) ->
+  | Texp_let(_rec_flag, pat_exp_list, body) ->
       List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
       is_nonexpansive body
   | Texp_function _ -> true
@@ -1561,16 +1576,20 @@ let rec is_nonexpansive exp =
   | Texp_construct( _, _, el) ->
       List.for_all is_nonexpansive el
   | Texp_variant(_, arg) -> is_nonexpansive_opt arg
-  | Texp_record(lbl_exp_list, opt_init_exp) ->
-      List.for_all
-        (fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
-        lbl_exp_list
-      && is_nonexpansive_opt opt_init_exp
-  | Texp_field(exp, lbl, _) -> is_nonexpansive exp
+  | Texp_record { fields; extended_expression } ->
+      Array.for_all
+        (fun (lbl, definition) ->
+           match definition with
+           | Overridden (_, exp) ->
+               lbl.lbl_mut = Immutable && is_nonexpansive exp
+           | Kept _ -> true)
+        fields
+      && is_nonexpansive_opt extended_expression
+  | Texp_field(exp, _, _) -> is_nonexpansive exp
   | Texp_array [] -> true
-  | Texp_ifthenelse(cond, ifso, ifnot) ->
+  | Texp_ifthenelse(_cond, ifso, ifnot) ->
       is_nonexpansive ifso && is_nonexpansive_opt ifnot
-  | Texp_sequence (e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
+  | Texp_sequence (_e1, e2) -> is_nonexpansive e2  (* PR#4354 *)
   | Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
       true
   (* Note: nonexpansive only means no _observable_ side effects *)
@@ -1645,7 +1664,8 @@ let rec approx_type env sty =
       newty (Ttuple (List.map (approx_type env) args))
   | Ptyp_constr (lid, ctl) ->
       begin try
-        let (path, decl) = Env.lookup_type lid.txt env in
+        let path = Env.lookup_type lid.txt env in
+        let decl = Env.find_type path env in
         if List.length ctl <> decl.type_arity then raise Not_found;
         let tyl = List.map (approx_type env) ctl in
         newconstr path tyl
@@ -1809,8 +1829,9 @@ let iter_ppat f p =
   | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg
   | Ppat_tuple lst ->  List.iter f lst
   | Ppat_exception p | Ppat_alias (p,_)
+  | Ppat_open (_,p)
   | Ppat_constraint (p,_) | Ppat_lazy p -> f p
-  | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args
+  | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args
 
 let contains_polymorphic_variant p =
   let rec loop p =
@@ -1821,18 +1842,21 @@ let contains_polymorphic_variant p =
   try loop p; false with Exit -> true
 
 let contains_gadt env p =
-  let rec loop p =
+  let rec loop env p =
     match p.ppat_desc with
-      Ppat_construct (lid, _) ->
+      | Ppat_construct (lid, _) ->
         begin try
           let cstrs = Env.lookup_all_constructors lid.txt env in
           List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
             cstrs
         with Not_found -> ()
-        end; iter_ppat loop p
-    | _ -> iter_ppat loop p
+        end; iter_ppat (loop env) p
+      | Ppat_open (lid,sub_p) ->
+        let _, new_env = !type_open Asttypes.Fresh env p.ppat_loc lid in
+        loop new_env sub_p
+    | _ -> iter_ppat (loop env) p
   in
-  try loop p; false with Exit -> true
+  try loop env p; false with Exit -> true
 
 let check_absent_variant env =
   iter_pattern
@@ -1855,7 +1879,7 @@ let check_absent_variant env =
 (* Duplicate types of values in the environment *)
 (* XXX Should we do something about global type variables too? *)
 
-let duplicate_ident_types loc caselist env =
+let duplicate_ident_types caselist env =
   let caselist =
     List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
   let idents = all_idents_cases caselist in
@@ -2057,11 +2081,17 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
           default;
        ]
       in
+      let sloc =
+        { Location.loc_start = spat.ppat_loc.Location.loc_start;
+          loc_end = default_loc.Location.loc_end;
+          loc_ghost = true }
+      in
       let smatch =
-        Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
+        Exp.match_ ~loc:sloc
+          (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
           scases
       in
-      let pat = Pat.var ~loc (mknoloc "*opt*") in
+      let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in
       let body =
         Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []]
           [Vb.mk spat smatch] sbody
@@ -2087,7 +2117,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         let ty = expand_head env ty_fun in
         if List.memq ty seen then () else
         match ty.desc with
-          Tarrow (l, ty_arg, ty_fun, com) ->
+          Tarrow (_l, ty_arg, ty_fun, _com) ->
             (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
             lower_args (ty::seen) ty_fun
         | _ -> ()
@@ -2109,8 +2139,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       begin_def ();
       let arg = type_exp env sarg in
       end_def ();
-      if is_nonexpansive arg then generalize arg.exp_type
-      else generalize_expansive env arg.exp_type;
+      if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type;
+      generalize arg.exp_type;
       let rec split_cases vc ec = function
         | [] -> List.rev vc, List.rev ec
         | {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest ->
@@ -2256,53 +2286,83 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         | [] -> ()
       in
       check_duplicates lbl_exp_list;
-      let opt_exp =
-        match opt_exp, lbl_exp_list with
-          None, _ -> None
-        | Some exp, (lid, lbl, lbl_exp) :: _ ->
+      let opt_exp, label_definitions =
+        let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
+        let matching_label lbl =
+          List.find
+            (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
+            lbl_exp_list
+        in
+        match opt_exp with
+          None ->
+            let label_definitions =
+              Array.map (fun lbl ->
+                  match matching_label lbl with
+                  | (lid, _lbl, lbl_exp) ->
+                      Overridden (lid, lbl_exp)
+                  | exception Not_found ->
+                      let present_indices =
+                        List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list
+                      in
+                      let label_names = extract_label_names env ty_expected in
+                      let rec missing_labels n = function
+                          [] -> []
+                        | lbl :: rem ->
+                            if List.mem n present_indices
+                            then missing_labels (n + 1) rem
+                            else lbl :: missing_labels (n + 1) rem
+                      in
+                      let missing = missing_labels 0 label_names in
+                      raise(Error(loc, env, Label_missing missing)))
+                lbl.lbl_all
+            in
+            None, label_definitions
+        | Some exp ->
             let ty_exp = instance env exp.exp_type in
             let unify_kept lbl =
-              (* do not connect overridden labels *)
-              if List.for_all
-                  (fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
-                  lbl_exp_list
-              then begin
-                let _, ty_arg1, ty_res1 = instance_label false lbl
-                and _, ty_arg2, ty_res2 = instance_label false lbl in
-                unify env ty_arg1 ty_arg2;
-                unify env (instance env ty_expected) ty_res2;
-                unify_exp_types exp.exp_loc env ty_exp ty_res1;
-              end in
-            Array.iter unify_kept lbl.lbl_all;
-            Some {exp with exp_type = ty_exp}
-        | _ -> assert false
+              match matching_label lbl with
+              | lid, _lbl, lbl_exp ->
+                  Overridden (lid, lbl_exp)
+              | exception Not_found -> begin
+                (* do not connect overridden labels *)
+                  let _, ty_arg1, ty_res1 = instance_label false lbl
+                  and _, ty_arg2, ty_res2 = instance_label false lbl in
+                  unify env ty_arg1 ty_arg2;
+                  unify env (instance env ty_expected) ty_res2;
+                  unify_exp_types exp.exp_loc env ty_exp ty_res1;
+                  Kept ty_arg1
+                end
+            in
+            let label_definitions = Array.map unify_kept lbl.lbl_all in
+            Some {exp with exp_type = ty_exp}, label_definitions
       in
       let num_fields =
         match lbl_exp_list with [] -> assert false
         | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
-      if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin
-        let present_indices =
-          List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
-        let label_names = extract_label_names sexp env ty_expected in
-        let rec missing_labels n = function
-            [] -> []
-          | lbl :: rem ->
-              if List.mem n present_indices then missing_labels (n + 1) rem
-              else lbl :: missing_labels (n + 1) rem
-        in
-        let missing = missing_labels 0 label_names in
-        raise(Error(loc, env, Label_missing missing))
-      end
-      else if opt_sexp <> None && List.length lid_sexp_list = num_fields then
-        Location.prerr_warning loc Warnings.Useless_record_with;
+      let opt_exp =
+        if opt_sexp <> None && List.length lid_sexp_list = num_fields then
+          (Location.prerr_warning loc Warnings.Useless_record_with; None)
+        else opt_exp
+      in
+      let label_descriptions, representation =
+        let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
+        lbl_all, lbl_repres
+      in
+      let fields =
+        Array.map2 (fun descr def -> descr, def)
+          label_descriptions label_definitions
+      in
       re {
-        exp_desc = Texp_record(lbl_exp_list, opt_exp);
+        exp_desc = Texp_record {
+            fields; representation;
+            extended_expression = opt_exp
+          };
         exp_loc = loc; exp_extra = [];
         exp_type = instance env ty_expected;
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_field(srecord, lid) ->
-      let (record, label, _) = type_label_access env loc srecord lid in
+      let (record, label, _) = type_label_access env srecord lid in
       let (_, ty_arg, ty_res) = instance_label false label in
       unify_exp env record ty_res;
       rue {
@@ -2312,7 +2372,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
-      let (record, label, opath) = type_label_access env loc srecord lid in
+      let (record, label, opath) = type_label_access env srecord lid in
       let ty_record = if opath = None then newvar () else record.exp_type in
       let (label_loc, label, newval) =
         type_label_exp false env loc ty_record (lid, label, snewval) in
@@ -2440,7 +2500,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                 end_def ();
                 let tv = newvar () in
                 let gen = generalizable tv.level arg.exp_type in
-                unify_var env tv arg.exp_type;
+                (try unify_var env tv arg.exp_type with Unify trace ->
+                  raise(Error(arg.exp_loc, env, Expr_type_clash trace)));
                 gen
               end else true
             in
@@ -2454,7 +2515,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                   && free_variables ~env ty' = [] ->
                 if not gen && (* first try a single coercion *)
                   let snap = snapshot () in
-                  let ty, b = enlarge_type env ty' in
+                  let ty, _b = enlarge_type env ty' in
                   try
                     force (); Ctype.unify env arg.exp_type ty; true
                   with Unify _ ->
@@ -2519,7 +2580,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       begin try
         let (meth, exp, typ) =
           match obj.exp_desc with
-            Texp_ident(path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
+            Texp_ident(_path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
               obj_meths := Some meths;
               let (id, typ) =
                 filter_self_method env met Private meths privty
@@ -2528,7 +2589,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                 Location.prerr_warning loc
                   (Warnings.Undeclared_virtual_method met);
               (Tmeth_val id, None, typ)
-          | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
+          | Texp_ident(_path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
               let method_id =
                 begin try List.assoc met methods with Not_found ->
                   let valid_methods = List.map fst methods in
@@ -2738,6 +2799,16 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         exp_type = ty;
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
+  | Pexp_letexception(cd, sbody) ->
+      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let body = type_expect newenv sbody ty_expected in
+      re {
+        exp_desc = Texp_letexception(cd, body);
+        exp_loc = loc; exp_extra = [];
+        exp_type = body.exp_type;
+        exp_attributes = sexp.pexp_attributes;
+        exp_env = env }
+
   | Pexp_assert (e) ->
       let cond = type_expect env e Predef.type_bool in
       let exp_type =
@@ -2834,6 +2905,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         type_loc = loc;
         type_attributes = [];
         type_immediate = false;
+        type_unboxed = unboxed_false_default_false;
       }
       in
       Ident.set_current_time ty.level;
@@ -2866,21 +2938,21 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
             exp_extra =
             (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
   | Pexp_pack m ->
-      let (p, nl, tl) =
+      let (p, nl) =
         match Ctype.expand_head env (instance env ty_expected) with
-          {desc = Tpackage (p, nl, tl)} ->
+          {desc = Tpackage (p, nl, _tl)} ->
             if !Clflags.principal &&
               (Ctype.expand_head env ty_expected).level < Btype.generic_level
             then
               Location.prerr_warning loc
                 (Warnings.Not_principal "this module packing");
-            (p, nl, tl)
+            (p, nl)
         | {desc = Tvar _} ->
             raise (Error (loc, env, Cannot_infer_signature))
         | _ ->
             raise (Error (loc, env, Not_a_packed_module ty_expected))
       in
-      let (modl, tl') = !type_package env m p nl tl in
+      let (modl, tl') = !type_package env m p nl in
       rue {
         exp_desc = Texp_pack modl;
         exp_loc = loc; exp_extra = [];
@@ -2977,7 +3049,7 @@ and type_function ?in_function loc attrs env ty_expected l caselist =
     exp_env = env }
 
 
-and type_label_access env loc srecord lid =
+and type_label_access env srecord lid =
   if !Clflags.principal then begin_def ();
   let record = type_exp ~recarg:Allowed env srecord in
   if !Clflags.principal then begin
@@ -3672,24 +3744,26 @@ and type_statement env sexp =
   begin_def();
   let exp = type_exp env sexp in
   end_def();
+  let ty = expand_head env exp.exp_type and tv = newvar() in
+  if is_Tvar ty && ty.level > tv.level then
+      Location.prerr_warning loc Warnings.Nonreturning_statement;
   if !Clflags.strict_sequence then
     let expected_ty = instance_def Predef.type_unit in
     unify_exp env exp expected_ty;
-    exp else
-  let ty = expand_head env exp.exp_type and tv = newvar() in
-  begin match ty.desc with
-  | Tarrow _ ->
-      Location.prerr_warning loc Warnings.Partial_application
-  | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
-  | Tvar _ when ty.level > tv.level ->
-      Location.prerr_warning loc Warnings.Nonreturning_statement
-  | Tvar _ ->
-      add_delayed_check (fun () -> check_application_result env true exp)
-  | _ ->
-      Location.prerr_warning loc Warnings.Statement_type
-  end;
-  unify_var env tv ty;
-  exp
+    exp
+  else begin
+    begin match ty.desc with
+    | Tarrow _ ->
+        Location.prerr_warning loc Warnings.Partial_application
+    | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+    | Tvar _ ->
+        add_delayed_check (fun () -> check_application_result env true exp)
+    | _ ->
+        Location.prerr_warning loc Warnings.Statement_type
+    end;
+    unify_var env tv ty;
+    exp
+  end
 
 (* Typing of match cases *)
 
@@ -3705,30 +3779,36 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
     then correct_levels ty_arg else ty_arg
   and ty_res, env =
     if has_gadts && not !Clflags.principal then
-      correct_levels ty_res, duplicate_ident_types loc caselist env
+      correct_levels ty_res, duplicate_ident_types caselist env
     else ty_res, env
   in
-  let do_init = has_gadts || List.length caselist > 1 in
+  let rec is_var spat =
+    match spat.ppat_desc with
+      Ppat_any | Ppat_var _ -> true
+    | Ppat_alias (spat, _) -> is_var spat
+    | _ -> false in
+  let needs_exhaust_check =
+    match caselist with
+      [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true
+    | [{pc_lhs}] when is_var pc_lhs -> false
+    | _ -> true
+  in
+  let init_env () =
+    (* raise level for existentials *)
+    begin_def ();
+    Ident.set_current_time (get_current_level ());
+    let lev = Ident.current_time () in
+    Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
+    (lev, Env.add_gadt_instance_level lev env)
+  in
   let lev, env =
-    if do_init then begin
-      (* raise level for existentials *)
-      begin_def ();
-      Ident.set_current_time (get_current_level ());
-      let lev = Ident.current_time () in
-      Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
-      (lev, Env.add_gadt_instance_level lev env)
-    end else (get_current_level (), env)
+    if has_gadts then init_env () else (get_current_level (), env)
   in
 (*  if has_gadts then
     Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
   (* Do we need to propagate polymorphism *)
   let propagate =
-    !Clflags.principal || do_init || (repr ty_arg).level = generic_level ||
-    let rec is_var spat =
-      match spat.ppat_desc with
-        Ppat_any | Ppat_var _ -> true
-      | Ppat_alias (spat, _) -> is_var spat
-      | _ -> false in
+    !Clflags.principal || has_gadts || (repr ty_arg).level = generic_level ||
     match caselist with
       [{pc_lhs}] when is_var pc_lhs -> false
     | _ -> true in
@@ -3823,25 +3903,31 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
     let ty_res' = instance env ty_res in
     List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
   end;
+  let do_init = has_gadts || needs_exhaust_check in
+  let lev, env =
+    if do_init && not has_gadts then init_env () else lev, env in
+  let ty_arg_check =
+    if do_init then
+      (* Hack: use for_saving to copy variables too *)
+      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg
+    else ty_arg
+  in
   let partial =
     if partial_flag then
-      check_partial ~lev env ty_arg loc cases
+      check_partial ~lev env ty_arg_check loc cases
     else
       Partial
   in
-  let unused_check ty_arg () =
+  let unused_check () =
     List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
       pat_env_list;
-    check_unused ~lev env (instance env ty_arg) cases ;
+    check_unused ~lev env (instance env ty_arg_check) cases ;
     Parmatch.check_ambiguous_bindings cases
   in
   if contains_polyvars || do_init then
-    let ty_arg_check =
-      (* Hack: use for_saving to copy variables too *)
-      Subst.type_expr (Subst.for_saving Subst.identity) ty_arg in
-    add_delayed_check (unused_check ty_arg_check)
+    add_delayed_check unused_check
   else
-    unused_check ty_arg ();
+    unused_check ();
   (* Check for unused cases, do not delay because of gadts *)
   if do_init then begin
     end_def ();
@@ -4049,7 +4135,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
 
 let type_binding env rec_flag spat_sexp_list scope =
   Typetexp.reset_type_variables();
-  let (pat_exp_list, new_env, unpacks) =
+  let (pat_exp_list, new_env, _unpacks) =
     type_let
       ~check:(fun s -> Warnings.Unused_value_declaration s)
       ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
@@ -4058,7 +4144,7 @@ let type_binding env rec_flag spat_sexp_list scope =
   (pat_exp_list, new_env)
 
 let type_let env rec_flag spat_sexp_list scope =
-  let (pat_exp_list, new_env, unpacks) =
+  let (pat_exp_list, new_env, _unpacks) =
     type_let env rec_flag spat_sexp_list scope false in
   (pat_exp_list, new_env)
 
@@ -4069,12 +4155,12 @@ let type_expression env sexp =
   begin_def();
   let exp = type_exp env sexp in
   end_def();
-  if is_nonexpansive exp then generalize exp.exp_type
-  else generalize_expansive env exp.exp_type;
+  if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type;
+  generalize exp.exp_type;
   match sexp.pexp_desc with
     Pexp_ident lid ->
       (* Special case for keeping type variables when looking-up a variable *)
-      let (path, desc) = Env.lookup_value lid.txt env in
+      let (_path, desc) = Env.lookup_value lid.txt env in
       {exp with exp_type = desc.val_type}
   | _ -> exp
 

diff --git a/typing/typecore.mli b/typing/typecore.mli
index 404483052953e837008c7959e09c4482af740f59..85fd0a82f71bf7e5cbf26f2a043c2b35d85ac719 100644 (file)
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -141,7 +141,7 @@ val type_object:
    Typedtree.class_structure * Types.class_signature * string list) ref
 val type_package:
   (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list ->
-  type_expr list -> Typedtree.module_expr * type_expr list) ref
+  Typedtree.module_expr * type_expr list) ref
 
 val create_package_type : Location.t -> Env.t ->
   Longident.t * (Longident.t * Parsetree.core_type) list ->

diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 0d6fa2786391a44121f8bad0831728df89be9b69..25afa6b55f0145164ec574c53a3c59050583b5df 100644 (file)
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -55,11 +55,27 @@ type error =
   | Cannot_unbox_or_untag_type of native_repr_kind
   | Deep_unbox_or_untag_attribute of native_repr_kind
   | Bad_immediate_attribute
+  | Bad_unboxed_attribute of string
+  | Wrong_unboxed_type_float
+  | Boxed_and_unboxed
 
 open Typedtree
 
 exception Error of Location.t * error
 
+(* Note: do not factor the branches in the following pattern-matching:
+   the records must be constants for the compiler to do sharing on them.
+*)
+let get_unboxed_from_attributes sdecl =
+  let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
+  let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
+  match boxed, unboxed, !Clflags.unboxed_types with
+  | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
+  | true, false, _ -> unboxed_false_default_false
+  | false, true, _ -> unboxed_true_default_false
+  | false, false, false -> unboxed_false_default_true
+  | false, false, true -> unboxed_true_default_true
+
 (* Enter all declared types in the environment as abstract types *)
 
 let enter_type env sdecl id =
@@ -77,6 +93,7 @@ let enter_type env sdecl id =
       type_loc = sdecl.ptype_loc;
       type_attributes = sdecl.ptype_attributes;
       type_immediate = false;
+      type_unboxed = unboxed_false_default_false;
     }
   in
   Env.add_type ~check:true id decl env
@@ -91,12 +108,38 @@ let update_type temp_env env id loc =
       with Ctype.Unify trace ->
         raise (Error(loc, Type_clash (env, trace)))
 
-(* Determine if a type is (an abbreviation for) the type "float" *)
 (* We use the Ctype.expand_head_opt version of expand_head to get access
    to the manifest type of private abbreviations. *)
+let rec get_unboxed_type_representation env ty fuel =
+  if fuel < 0 then None else
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  match ty.desc with
+  | Tconstr (p, args, _) ->
+    begin match Env.find_type p env with
+    | exception Not_found -> Some ty
+    | {type_unboxed = {unboxed = false}} -> Some ty
+    | {type_params; type_kind =
+         Type_record ([{ld_type = ty2; _}], _)
+       | Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
+       | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
+
+         -> get_unboxed_type_representation env
+             (Ctype.apply env type_params ty2 args) (fuel - 1)
+    | {type_kind=Type_abstract} -> None
+          (* This case can occur when checking a recursive unboxed type
+             declaration. *)
+    | _ -> assert false (* only the above can be unboxed *)
+    end
+  | _ -> Some ty
+
+let get_unboxed_type_representation env ty =
+  get_unboxed_type_representation env ty 100000
+;;
+
+(* Determine if a type's values are represented by floats at run-time. *)
 let is_float env ty =
-  match Ctype.repr (Ctype.expand_head_opt env ty) with
-    {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
+  match get_unboxed_type_representation env ty with
+    Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
   | _ -> false
 
 (* Determine if a type definition defines a fixed type. (PW) *)
@@ -157,7 +200,7 @@ let make_params env params =
   in
     List.map make_param params
 
-let transl_labels loc env closed lbls =
+let transl_labels env closed lbls =
   assert (lbls <> []);
   let all_labels = ref StringSet.empty in
   List.iter
@@ -189,21 +232,21 @@ let transl_labels loc env closed lbls =
       lbls in
   lbls, lbls'
 
-let transl_constructor_arguments loc env closed = function
+let transl_constructor_arguments env closed = function
   | Pcstr_tuple l ->
       let l = List.map (transl_simple_type env closed) l in
       Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
       Cstr_tuple l
   | Pcstr_record l ->
-      let lbls, lbls' = transl_labels loc env closed l in
+      let lbls, lbls' = transl_labels env closed l in
       Types.Cstr_record lbls',
       Cstr_record lbls
 
-let make_constructor loc env type_path type_params sargs sret_type =
+let make_constructor env type_path type_params sargs sret_type =
   match sret_type with
   | None ->
       let args, targs =
-        transl_constructor_arguments loc env true sargs
+        transl_constructor_arguments env true sargs
       in
         targs, None, args, None
   | Some sret_type ->
@@ -212,7 +255,7 @@ let make_constructor loc env type_path type_params sargs sret_type =
       let z = narrow () in
       reset_type_variables ();
       let args, targs =
-        transl_constructor_arguments loc env false sargs
+        transl_constructor_arguments env false sargs
       in
       let tret_type = transl_simple_type env false sret_type in
       let ret_type = tret_type.ctyp_type in
@@ -226,6 +269,31 @@ let make_constructor loc env type_path type_params sargs sret_type =
       widen z;
       targs, Some tret_type, args, Some ret_type
 
+(* Check that the argument to a GADT constructor is compatible with unboxing
+   the type, given the existential variables introduced by this constructor. *)
+let rec check_unboxed_gadt_arg loc ex env ty =
+  match get_unboxed_type_representation env ty with
+  | Some {desc = Tvar _; id} ->
+    let f t = (Btype.repr t).id = id in
+    if List.exists f ex then raise(Error(loc, Wrong_unboxed_type_float))
+  | Some {desc = Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil
+                 | Tvariant _; _} ->
+    ()
+    (* A comment in [Translcore.transl_exp0] claims the above cannot be
+       represented by floats. *)
+  | Some {desc = Tconstr (p, args, _); _} ->
+    let tydecl = Env.find_type p env in
+    assert (not tydecl.type_unboxed.unboxed);
+    if tydecl.type_kind = Type_abstract then
+      List.iter (check_unboxed_gadt_arg loc ex env) args
+  | Some {desc = Tfield _ | Tlink _ | Tsubst _; _} -> assert false
+  | Some {desc = Tunivar _; _} -> ()
+  | Some {desc = Tpoly (t2, _); _} -> check_unboxed_gadt_arg loc ex env t2
+  | None -> ()
+      (* This case is tricky: the argument is another (or the same) type
+         in the same recursive definition. In this case we don't have to
+         check because we will also check that other type for correctness. *)
+
 let transl_declaration env sdecl id =
   (* Bind type parameters *)
   reset_type_variables();
@@ -238,9 +306,54 @@ let transl_declaration env sdecl id =
       transl_simple_type env false sty', loc)
     sdecl.ptype_cstrs
   in
+  let raw_status = get_unboxed_from_attributes sdecl in
+  if raw_status.unboxed && not raw_status.default then begin
+    match sdecl.ptype_kind with
+    | Ptype_abstract ->
+        raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                      "it is abstract"))
+    | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has no argument"))
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] -> ()
+    | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has more than one argument"))
+    | Ptype_variant [{pcd_args = Pcstr_record
+                        [{pld_mutable=Immutable; _}]; _}] -> ()
+    | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable"))
+    | Ptype_variant [{pcd_args = Pcstr_record _; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "its constructor has more than one argument"))
+    | Ptype_variant _ ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it has more than one constructor"))
+    | Ptype_record [{pld_mutable=Immutable; _}] -> ()
+    | Ptype_record [{pld_mutable=Mutable; _}] ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it is mutable"))
+    | Ptype_record _ ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "it has more than one field"))
+    | Ptype_open ->
+      raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
+                    "extensible variant types cannot be unboxed"))
+  end;
+  let unboxed_status =
+    match sdecl.ptype_kind with
+    | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
+      | Ptype_variant [{pcd_args = Pcstr_record
+                          [{pld_mutable = Immutable; _}]; _}]
+      | Ptype_record [{pld_mutable = Immutable; _}] ->
+    raw_status
+    | _ -> (* The type is not unboxable, mark it as boxed *)
+      unboxed_false_default_false
+  in
+  let unbox = unboxed_status.unboxed in
   let (tkind, kind) =
     match sdecl.ptype_kind with
-        Ptype_abstract -> Ttype_abstract, Type_abstract
+      | Ptype_abstract -> Ttype_abstract, Type_abstract
       | Ptype_variant scstrs ->
         assert (scstrs <> []);
         let all_constrs = ref StringSet.empty in
@@ -251,15 +364,29 @@ let transl_declaration env sdecl id =
             all_constrs := StringSet.add name !all_constrs)
           scstrs;
         if List.length
-          (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
-          > (Config.max_tag + 1) then
+            (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
+           > (Config.max_tag + 1) then
           raise(Error(sdecl.ptype_loc, Too_many_constructors));
         let make_cstr scstr =
           let name = Ident.create scstr.pcd_name.txt in
           let targs, tret_type, args, ret_type =
-            make_constructor scstr.pcd_loc env (Path.Pident id) params
+            make_constructor env (Path.Pident id) params
                              scstr.pcd_args scstr.pcd_res
           in
+          if unbox then begin
+            (* Cannot unbox a type when the argument can be both float and
+               non-float because it interferes with the dynamic float array
+               optimization. This can only happen when the type is a GADT
+               and the argument is an existential type variable or an
+               unboxed (or abstract) type constructor applied to some
+               existential type variable. Of course we also have to rule
+               out any abstract type constructor applied to anything that
+               might be an existential type variable. *)
+            match Datarepr.constructor_existentials args ret_type with
+            | _, [] -> ()
+            | [argty], ex -> check_unboxed_gadt_arg sdecl.ptype_loc ex env argty
+            | _ -> assert false
+          end;
           let tcstr =
             { cd_id = name;
               cd_name = scstr.pcd_name;
@@ -280,9 +407,10 @@ let transl_declaration env sdecl id =
         let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
           Ttype_variant tcstrs, Type_variant cstrs
       | Ptype_record lbls ->
-          let lbls, lbls' = transl_labels sdecl.ptype_loc env true lbls in
+          let lbls, lbls' = transl_labels env true lbls in
           let rep =
-            if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
+            if unbox then Record_unboxed false
+            else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
             then Record_float
             else Record_regular
           in
@@ -307,6 +435,7 @@ let transl_declaration env sdecl id =
         type_loc = sdecl.ptype_loc;
         type_attributes = sdecl.ptype_attributes;
         type_immediate = false;
+        type_unboxed = unboxed_status;
       } in
 
   (* Check constraints *)
@@ -320,7 +449,7 @@ let transl_declaration env sdecl id =
     Ctype.end_def ();
   (* Add abstract row *)
     if is_fixed_type sdecl then begin
-      let (p, _) =
+      let p =
         try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env
         with Not_found -> assert false in
       set_fixed_row env sdecl.ptype_loc p decl
@@ -492,9 +621,9 @@ let check_abbrev env sdecl (id, decl) =
 
 let check_well_founded env loc path to_check ty =
   let visited = ref TypeMap.empty in
-  let rec check ty0 exp_nodes ty =
+  let rec check ty0 parents ty =
     let ty = Btype.repr ty in
-    if TypeSet.mem ty exp_nodes then begin
+    if TypeSet.mem ty parents then begin
       (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
       if match ty0.desc with
       | Tconstr (p, _, _) -> Path.same p path
@@ -502,41 +631,51 @@ let check_well_founded env loc path to_check ty =
       then raise (Error (loc, Recursive_abbrev (Path.name path)))
       else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
     end;
-    let (fini, exp_nodes) =
+    let (fini, parents) =
       try
         let prev = TypeMap.find ty !visited in
-        if TypeSet.subset exp_nodes prev then (true, exp_nodes) else
-        (false, TypeSet.union exp_nodes prev)
+        if TypeSet.subset parents prev then (true, parents) else
+        (false, TypeSet.union parents prev)
       with Not_found ->
-        (false, exp_nodes)
+        (false, parents)
     in
-    let snap = Btype.snapshot () in
-    if fini then () else try
-      visited := TypeMap.add ty exp_nodes !visited;
+    if fini then () else
+    let rec_ok =
       match ty.desc with
-      | Tconstr(p, args, _)
-        when not (TypeSet.is_empty exp_nodes) || to_check p ->
+        Tconstr(p,_,_) ->
+          !Clflags.recursive_types && Ctype.is_contractive env p
+      | Tobject _ | Tvariant _ -> true
+      | _ -> !Clflags.recursive_types
+    in
+    let visited' = TypeMap.add ty parents !visited in
+    let arg_exn =
+      try
+        visited := visited';
+        let parents =
+          if rec_ok then TypeSet.empty else TypeSet.add ty parents in
+        Btype.iter_type_expr (check ty0 parents) ty;
+        None
+      with e ->
+        visited := visited'; Some e
+    in
+    match ty.desc with
+    | Tconstr(p, _, _) when arg_exn <> None || to_check p ->
+        if to_check p then may raise arg_exn
+        else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
+        begin try
           let ty' = Ctype.try_expand_once_opt env ty in
-          let ty0 = if TypeSet.is_empty exp_nodes then ty else ty0 in
-          check ty0 (TypeSet.add ty exp_nodes) ty'
-      | _ -> raise Ctype.Cannot_expand
-    with
-    | Ctype.Cannot_expand ->
-        let rec_ok =
-          match ty.desc with
-            Tconstr(p,_,_) ->
-              !Clflags.recursive_types && Ctype.is_contractive env p
-          | Tobject _ | Tvariant _ -> true
-          | _ -> !Clflags.recursive_types
-        in
-        let nodes =
-          if rec_ok then TypeSet.empty else exp_nodes in
-        Btype.iter_type_expr (check ty0 nodes) ty
-    | Ctype.Unify _ ->
-        (* Will be detected by check_recursion *)
-        Btype.backtrack snap
+          let ty0 = if TypeSet.is_empty parents then ty else ty0 in
+          check ty0 (TypeSet.add ty parents) ty'
+        with
+          Ctype.Cannot_expand -> may raise arg_exn
+        end
+    | _ -> may raise arg_exn
   in
-  Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  let snap = Btype.snapshot () in
+  try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
+  with Ctype.Unify _ ->
+    (* Will be detected by check_recursion *)
+    Btype.backtrack snap
 
 let check_well_founded_manifest env loc path decl =
   if decl.type_manifest = None then () else
@@ -688,6 +827,8 @@ let compute_variance env visited vari ty =
                     null [May_pos; May_neg; May_weak]
                 in
                 let v = inter vari upper in
+                (* cf PR#7269:
+                   if List.length tyl > 1 then upper else inter vari upper *)
                 List.iter (compute_variance_rec v) tyl
             | _ -> ())
           row.row_fields;
@@ -741,7 +882,7 @@ let compute_variance_type env check (required, loc) decl tyl =
     if fvl = [] then () else
     let tvl2 = ref TypeMap.empty in
     List.iter2
-      (fun ty (p,n,i) ->
+      (fun ty (p,n,_) ->
         if Btype.is_Tvar ty then () else
         let v =
           if p then if n then full else covariant else conjugate covariant in
@@ -823,7 +964,7 @@ let compute_variance_gadt env check (required, loc as rloc) decl
           let fvl = List.map (Ctype.free_variables ?env:None) tyl in
           let _ =
             List.fold_left2
-              (fun (fv1,fv2) ty (c,n,i) ->
+              (fun (fv1,fv2) ty (c,n,_) ->
                 match fv2 with [] -> assert false
                 | fv :: fv2 ->
                     (* fv1 @ fv2 = free_variables of other parameters *)
@@ -881,17 +1022,23 @@ let compute_variance_decl env check decl (required, _ as rloc) =
         (mn @ List.map (fun {Types.ld_mutable; ld_type} ->
              (ld_mutable = Mutable, ld_type)) ftl)
 
-let is_sharp id =
+let is_hash id =
   let s = Ident.name id in
   String.length s > 0 && s.[0] = '#'
 
 let marked_as_immediate decl =
-  List.exists
-    (fun (loc, _) -> loc.txt = "immediate")
-    decl.type_attributes
+  Builtin_attributes.immediate decl.type_attributes
 
 let compute_immediacy env tdecl =
   match (tdecl.type_kind, tdecl.type_manifest) with
+  | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _)
+    | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _)
+    | (Type_record ([{ld_type = arg; _}], _), _)
+  when tdecl.type_unboxed.unboxed ->
+    begin match get_unboxed_type_representation env arg with
+    | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr)
+    | None -> false
+    end
   | (Type_variant (_ :: _ as cstrs), _) ->
     not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
   | (Type_abstract, Some(typ)) ->
@@ -915,14 +1062,14 @@ let rec compute_properties_fixpoint env decls required variances immediacies =
   in
   let new_variances =
     List.map2
-      (fun (id, decl) -> compute_variance_decl new_env false decl)
+      (fun (_id, decl) -> compute_variance_decl new_env false decl)
       new_decls required
   in
   let new_variances =
     List.map2 (List.map2 Variance.union) new_variances variances in
   let new_immediacies =
     List.map
-      (fun (id, decl) -> compute_immediacy new_env decl)
+      (fun (_id, decl) -> compute_immediacy new_env decl)
       new_decls
   in
   if new_variances <> variances || new_immediacies <> immediacies then
@@ -941,13 +1088,13 @@ let rec compute_properties_fixpoint env decls required variances immediacies =
       else ())
       new_decls;
     List.iter2
-      (fun (id, decl) req -> if not (is_sharp id) then
+      (fun (id, decl) req -> if not (is_hash id) then
         ignore (compute_variance_decl new_env true decl req))
       new_decls required;
     new_decls, new_env
   end
 
-let init_variance (id, decl) =
+let init_variance (_id, decl) =
   List.map (fun _ -> Variance.null) decl.type_params
 
 let add_injectivity =
@@ -962,7 +1109,7 @@ let add_injectivity =
 let compute_variance_decls env cldecls =
   let decls, required =
     List.fold_right
-      (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, ci) (decls, req) ->
+      (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) ->
         let variance = List.map snd ci.ci_params in
         (obj_id, obj_abbr) :: decls,
         (add_injectivity variance, ci.ci_loc) :: req)
@@ -1162,7 +1309,7 @@ let transl_type_decl env rec_flag sdecl_list =
   (* Keep original declaration *)
   let final_decls =
     List.map2
-      (fun tdecl (id2, decl) ->
+      (fun tdecl (_id2, decl) ->
         { tdecl with typ_type = decl }
       ) tdecls final_decls
   in
@@ -1178,7 +1325,7 @@ let transl_extension_constructor env type_path type_params
     match sext.pext_kind with
       Pext_decl(sargs, sret_type) ->
         let targs, tret_type, args, ret_type =
-          make_constructor sext.pext_loc env type_path typext_params
+          make_constructor env type_path typext_params
             sargs sret_type
         in
           args, ret_type, Text_decl(targs, tret_type)
@@ -1475,6 +1622,18 @@ let rec parse_native_repr_attributes env core_type ty ~global_repr =
   | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
   | _ -> ([], make_native_repr env core_type ty ~global_repr)
 
+
+let check_unboxable env loc ty =
+  let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
+  try match ty.desc with
+  | Tconstr (p, _, _) ->
+    let tydecl = Env.find_type p env in
+    if tydecl.type_unboxed.unboxed then
+      Location.prerr_warning loc
+        (Warnings.Unboxable_type_in_prim_decl (Path.name p))
+  | _ -> ()
+  with Not_found -> ()
+
 (* Translate a value declaration *)
 let transl_value_decl env loc valdecl =
   let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
@@ -1509,6 +1668,7 @@ let transl_value_decl env loc valdecl =
       && prim.prim_arity > 5
       && prim.prim_native_name = ""
       then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
+      Btype.iter_type_expr (check_unboxable env loc) ty;
       { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
         val_attributes = valdecl.pval_attributes }
   in
@@ -1569,11 +1729,16 @@ let transl_with_constraint env id row_path orig_decl sdecl =
   && sdecl.ptype_private = Private then
     Location.prerr_warning sdecl.ptype_loc
       (Warnings.Deprecated "spurious use of private");
+  let type_kind, type_unboxed =
+    if arity_ok && man <> None then
+      orig_decl.type_kind, orig_decl.type_unboxed
+    else
+      Type_abstract, unboxed_false_default_false
+  in
   let decl =
     { type_params = params;
       type_arity = List.length params;
-      type_kind =
-        if arity_ok && man <> None then orig_decl.type_kind else Type_abstract;
+      type_kind;
       type_private = priv;
       type_manifest = man;
       type_variance = [];
@@ -1581,6 +1746,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
       type_loc = sdecl.ptype_loc;
       type_attributes = sdecl.ptype_attributes;
       type_immediate = false;
+      type_unboxed;
     }
   in
   begin match row_path with None -> ()
@@ -1628,12 +1794,13 @@ let abstract_type_decl arity =
       type_loc = Location.none;
       type_attributes = [];
       type_immediate = false;
+      type_unboxed = unboxed_false_default_false;
      } in
   Ctype.end_def();
   generalize_decl decl;
   decl
 
-let approx_type_decl env sdecl_list =
+let approx_type_decl sdecl_list =
   List.map
     (fun sdecl ->
       (Ident.create sdecl.ptype_name.txt,
@@ -1684,7 +1851,7 @@ let explain_unbound_single ppf tv ty =
       let row = Btype.row_repr row in
       if row.row_more == tv then trivial ty else
       explain_unbound ppf tv row.row_fields
-        (fun (l,f) -> match Btype.row_field_repr f with
+        (fun (_l,f) -> match Btype.row_field_repr f with
           Rpresent (Some t) -> t
         | Reither (_,[t],_,_) -> t
         | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
@@ -1873,6 +2040,14 @@ let report_error ppf = function
       fprintf ppf "@[%s@ %s@]"
         "Types marked with the immediate attribute must be"
         "non-pointer types like int or bool"
+  | Bad_unboxed_attribute msg ->
+      fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
+  | Wrong_unboxed_type_float ->
+      fprintf ppf "@[This type cannot be unboxed because@ \
+                   it might contain both float and non-float values.@ \
+                   You should annotate it with [%@%@ocaml.boxed].@]"
+  | Boxed_and_unboxed ->
+      fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
 
 let () =
   Location.register_error_of_exn

diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index fa57b17c5cf5c4b8af083c6bef0cc03a887a8634..db4875f96f26b85ccf6ca8e6b1057b7836ba9987 100644 (file)
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -40,7 +40,7 @@ val transl_with_constraint:
 
 val abstract_type_decl: int -> type_declaration
 val approx_type_decl:
-    Env.t -> Parsetree.type_declaration list ->
+    Parsetree.type_declaration list ->
                                   (Ident.t * type_declaration) list
 val check_recmod_typedecl:
     Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
@@ -59,6 +59,10 @@ val compute_variance_decls:
     (Types.type_declaration * Types.type_declaration *
      Types.class_declaration * Types.class_type_declaration) list
 
+(* for typeopt.ml *)
+val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+
+
 type native_repr_kind = Unboxed | Untagged
 
 type error =
@@ -92,6 +96,9 @@ type error =
   | Cannot_unbox_or_untag_type of native_repr_kind
   | Deep_unbox_or_untag_attribute of native_repr_kind
   | Bad_immediate_attribute
+  | Bad_unboxed_attribute of string
+  | Wrong_unboxed_type_float
+  | Boxed_and_unboxed
 
 exception Error of Location.t * error
 

diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index f3649f1ed5ee7deac34a5b8ffceb1c237eb231f3..d06a13b9ac76c6881952fe069d00566192e04036 100644 (file)
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -38,6 +38,7 @@ type pattern =
 and pat_extra =
   | Tpat_constraint of core_type
   | Tpat_type of Path.t * Longident.t loc
+  | Tpat_open of Path.t * Longident.t loc * Env.t
   | Tpat_unpack
 
 and pattern_desc =
@@ -84,9 +85,11 @@ and expression_desc =
   | Texp_construct of
       Longident.t loc * constructor_description * expression list
   | Texp_variant of label * expression option
-  | Texp_record of
-      (Longident.t loc * label_description * expression) list *
-        expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
   | Texp_field of expression * Longident.t loc * label_description
   | Texp_setfield of
       expression * Longident.t loc * label_description * expression
@@ -103,6 +106,7 @@ and expression_desc =
   | Texp_setinstvar of Path.t * Path.t * string loc * expression
   | Texp_override of Path.t * (Path.t * string loc * expression) list
   | Texp_letmodule of Ident.t * string loc * module_expr * expression
+  | Texp_letexception of extension_constructor * expression
   | Texp_assert of expression
   | Texp_lazy of expression
   | Texp_object of class_structure * string list
@@ -121,6 +125,10 @@ and case =
      c_rhs: expression;
     }
 
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
 (* Value expressions for the class language *)
 
 and class_expr =
@@ -505,7 +513,7 @@ and 'a class_infos =
     ci_id_class: Ident.t;
     ci_id_class_type: Ident.t;
     ci_id_object: Ident.t;
-    ci_id_typesharp: Ident.t;
+    ci_id_typehash: Ident.t;
     ci_expr: 'a;
     ci_decl: Types.class_declaration;
     ci_type_decl: Types.class_type_declaration;
@@ -518,10 +526,10 @@ and 'a class_infos =
 let iter_pattern_desc f = function
   | Tpat_alias(p, _, _) -> f p
   | Tpat_tuple patl -> List.iter f patl
-  | Tpat_construct(_, cstr, patl) -> List.iter f patl
+  | Tpat_construct(_, _, patl) -> List.iter f patl
   | Tpat_variant(_, pat, _) -> may f pat
   | Tpat_record (lbl_pat_list, _) ->
-      List.iter (fun (_, lbl, pat) -> f pat) lbl_pat_list
+      List.iter (fun (_, _, pat) -> f pat) lbl_pat_list
   | Tpat_array patl -> List.iter f patl
   | Tpat_or(p1, p2, _) -> f p1; f p2
   | Tpat_lazy p -> f p

diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index ec697cdd5961653e89b5cfd45440525c8ad40c15..c773083bd9278b31c2cd4dc3c515dc0c8161b299 100644 (file)
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -56,6 +56,7 @@ and pat_extra =
                            where [disjunction] is a [Tpat_or _] representing the
                            branches of [tconst].
          *)
+  | Tpat_open of Path.t * Longident.t loc * Env.t
   | Tpat_unpack
         (** (module P)     { pat_desc  = Tpat_var "P"
                            ; pat_extra = (Tpat_unpack, _, _) :: ... }
@@ -185,9 +186,22 @@ and expression_desc =
             C (E1, ..., En)  [E1;...;En]
          *)
   | Texp_variant of label * expression option
-  | Texp_record of
-      (Longident.t loc * label_description * expression) list *
-        expression option
+  | Texp_record of {
+      fields : ( Types.label_description * record_label_definition ) array;
+      representation : Types.record_representation;
+      extended_expression : expression option;
+    }
+        (** { l1=P1; ...; ln=Pn }           (extended_expression = None)
+            { E0 with l1=P1; ...; ln=Pn }   (extended_expression = Some E0)
+
+            Invariant: n > 0
+
+            If the type is { l1: t1; l2: t2 }, the expression
+            { E0 with t2=P2 } is represented as
+            Texp_record
+              { fields = [| l1, Kept t1; l2 Override P2 |]; representation;
+                extended_expression = Some E0 }
+        *)
   | Texp_field of expression * Longident.t loc * label_description
   | Texp_setfield of
       expression * Longident.t loc * label_description * expression
@@ -204,6 +218,7 @@ and expression_desc =
   | Texp_setinstvar of Path.t * Path.t * string loc * expression
   | Texp_override of Path.t * (Path.t * string loc * expression) list
   | Texp_letmodule of Ident.t * string loc * module_expr * expression
+  | Texp_letexception of extension_constructor * expression
   | Texp_assert of expression
   | Texp_lazy of expression
   | Texp_object of class_structure * string list
@@ -222,6 +237,10 @@ and case =
      c_rhs: expression;
     }
 
+and record_label_definition =
+  | Kept of Types.type_expr
+  | Overridden of Longident.t loc * expression
+
 (* Value expressions for the class language *)
 
 and class_expr =
@@ -613,7 +632,7 @@ and 'a class_infos =
     ci_id_class: Ident.t;
     ci_id_class_type : Ident.t;
     ci_id_object : Ident.t;
-    ci_id_typesharp : Ident.t;
+    ci_id_typehash : Ident.t;
     ci_expr: 'a;
     ci_decl: Types.class_declaration;
     ci_type_decl : Types.class_type_declaration;

diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index 39f0f6c7d37eb9e12203001362bc27559f4f5ba5..86b96531ce00cefcca9e8d0362e8db9c5012c3aa 100644 (file)
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -150,7 +150,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
             List.iter (fun (ci, _) -> iter_class_declaration ci) list
         | Tstr_class_type list ->
             List.iter
-              (fun (id, _, ct) -> iter_class_type_declaration ct)
+              (fun (_, _, ct) -> iter_class_type_declaration ct)
               list
         | Tstr_include incl -> iter_module_expr incl.incl_mod
         | Tstr_attribute _ ->
@@ -174,13 +174,13 @@ module MakeIterator(Iter : IteratorArgument) : sig
       iter_constructor_arguments cd.cd_args;
       option iter_core_type cd.cd_res;
 
-    and iter_type_parameter (ct, v) =
+    and iter_type_parameter (ct, _v) =
       iter_core_type ct
 
     and iter_type_declaration decl =
       Iter.enter_type_declaration decl;
       List.iter iter_type_parameter decl.typ_params;
-      List.iter (fun (ct1, ct2, loc) ->
+      List.iter (fun (ct1, ct2, _loc) ->
           iter_core_type ct1;
           iter_core_type ct2
       ) decl.typ_cstrs;
@@ -224,23 +224,24 @@ module MakeIterator(Iter : IteratorArgument) : sig
       List.iter (fun (cstr, _, _attrs) -> match cstr with
               | Tpat_type _ -> ()
               | Tpat_unpack -> ()
+              | Tpat_open _ -> ()
               | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra;
       begin
         match pat.pat_desc with
           Tpat_any -> ()
-        | Tpat_var (id, _) -> ()
+        | Tpat_var _ -> ()
         | Tpat_alias (pat1, _, _) -> iter_pattern pat1
-        | Tpat_constant cst -> ()
+        | Tpat_constant _ -> ()
         | Tpat_tuple list ->
             List.iter iter_pattern list
         | Tpat_construct (_, _, args) ->
             List.iter iter_pattern args
-        | Tpat_variant (label, pato, _) ->
+        | Tpat_variant (_, pato, _) ->
             begin match pato with
                 None -> ()
               | Some pat -> iter_pattern pat
             end
-        | Tpat_record (list, closed) ->
+        | Tpat_record (list, _closed) ->
             List.iter (fun (_, _, pat) -> iter_pattern pat) list
         | Tpat_array list -> List.iter iter_pattern list
         | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
@@ -258,22 +259,22 @@ module MakeIterator(Iter : IteratorArgument) : sig
             iter_core_type ct
         | Texp_coerce (cty1, cty2) ->
             option iter_core_type cty1; iter_core_type cty2
-        | Texp_open (_, path, _, _) -> ()
+        | Texp_open _ -> ()
         | Texp_poly cto -> option iter_core_type cto
-        | Texp_newtype s -> ())
+        | Texp_newtype _ -> ())
         exp.exp_extra;
       begin
         match exp.exp_desc with
-          Texp_ident (path, _, _) -> ()
-        | Texp_constant cst -> ()
+          Texp_ident _ -> ()
+        | Texp_constant _ -> ()
         | Texp_let (rec_flag, list, exp) ->
             iter_bindings rec_flag list;
             iter_expression exp
-        | Texp_function (label, cases, _) ->
+        | Texp_function (_label, cases, _) ->
             iter_cases cases
         | Texp_apply (exp, list) ->
             iter_expression exp;
-            List.iter (fun (label, expo) ->
+            List.iter (fun (_label, expo) ->
                 match expo with
                   None -> ()
                 | Some exp -> iter_expression exp
@@ -289,20 +290,23 @@ module MakeIterator(Iter : IteratorArgument) : sig
             List.iter iter_expression list
         | Texp_construct (_, _, args) ->
             List.iter iter_expression args
-        | Texp_variant (label, expo) ->
+        | Texp_variant (_label, expo) ->
             begin match expo with
                 None -> ()
               | Some exp -> iter_expression exp
             end
-        | Texp_record (list, expo) ->
-            List.iter (fun (_, _, exp) -> iter_expression exp) list;
-            begin match expo with
+        | Texp_record { fields; extended_expression; _ } ->
+            Array.iter (function
+                | _, Kept _ -> ()
+                | _, Overridden (_, exp) -> iter_expression exp)
+              fields;
+            begin match extended_expression with
                 None -> ()
               | Some exp -> iter_expression exp
             end
-        | Texp_field (exp, _, label) ->
+        | Texp_field (exp, _, _label) ->
             iter_expression exp
-        | Texp_setfield (exp1, _, label, exp2) ->
+        | Texp_setfield (exp1, _, _label, exp2) ->
             iter_expression exp1;
             iter_expression exp2
         | Texp_array list ->
@@ -320,28 +324,31 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Texp_while (exp1, exp2) ->
             iter_expression exp1;
             iter_expression exp2
-        | Texp_for (id, _, exp1, exp2, dir, exp3) ->
+        | Texp_for (_id, _, exp1, exp2, _dir, exp3) ->
             iter_expression exp1;
             iter_expression exp2;
             iter_expression exp3
-        | Texp_send (exp, meth, expo) ->
+        | Texp_send (exp, _meth, expo) ->
             iter_expression exp;
           begin
             match expo with
                 None -> ()
               | Some exp -> iter_expression exp
           end
-        | Texp_new (path, _, _) -> ()
-        | Texp_instvar (_, path, _) -> ()
+        | Texp_new _ -> ()
+        | Texp_instvar _ -> ()
         | Texp_setinstvar (_, _, _, exp) ->
             iter_expression exp
         | Texp_override (_, list) ->
-            List.iter (fun (path, _, exp) ->
+            List.iter (fun (_path, _, exp) ->
                 iter_expression exp
             ) list
-        | Texp_letmodule (id, _, mexpr, exp) ->
+        | Texp_letmodule (_id, _, mexpr, exp) ->
             iter_module_expr mexpr;
             iter_expression exp
+        | Texp_letexception (cd, exp) ->
+            iter_extension_constructor cd;
+            iter_expression exp
         | Texp_assert exp -> iter_expression exp
         | Texp_lazy exp -> iter_expression exp
         | Texp_object (cl, _) ->
@@ -357,7 +364,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
     and iter_package_type pack =
       Iter.enter_package_type pack;
-      List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields;
+      List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields;
       Iter.leave_package_type pack;
 
     and iter_signature sg =
@@ -424,14 +431,14 @@ module MakeIterator(Iter : IteratorArgument) : sig
       Iter.enter_module_type mty;
       begin
         match mty.mty_desc with
-          Tmty_ident (path, _) -> ()
-        | Tmty_alias (path, _) -> ()
+          Tmty_ident _ -> ()
+        | Tmty_alias _ -> ()
         | Tmty_signature sg -> iter_signature sg
-        | Tmty_functor (id, _, mtype1, mtype2) ->
+        | Tmty_functor (_, _, mtype1, mtype2) ->
             Misc.may iter_module_type mtype1; iter_module_type mtype2
         | Tmty_with (mtype, list) ->
             iter_module_type mtype;
-            List.iter (fun (path, _, withc) ->
+            List.iter (fun (_path, _, withc) ->
                 iter_with_constraint withc
             ) list
         | Tmty_typeof mexpr ->
@@ -454,9 +461,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
       Iter.enter_module_expr mexpr;
       begin
         match mexpr.mod_desc with
-          Tmod_ident (p, _) -> ()
+          Tmod_ident _ -> ()
         | Tmod_structure st -> iter_structure st
-        | Tmod_functor (id, _, mtype, mexpr) ->
+        | Tmod_functor (_, _, mtype, mexpr) ->
             Misc.may iter_module_type mtype;
             iter_module_expr mexpr
         | Tmod_apply (mexp1, mexp2, _) ->
@@ -467,7 +474,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
             iter_module_expr mexpr;
             iter_module_type mtype
-        | Tmod_unpack (exp, mty) ->
+        | Tmod_unpack (exp, _mty) ->
             iter_expression exp
 (*          iter_module_type mty *)
       end;
@@ -480,14 +487,14 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Tcl_constraint (cl, None, _, _, _ ) ->
             iter_class_expr cl;
         | Tcl_structure clstr -> iter_class_structure clstr
-        | Tcl_fun (label, pat, priv, cl, partial) ->
+        | Tcl_fun (_label, pat, priv, cl, _partial) ->
           iter_pattern pat;
-          List.iter (fun (id, _, exp) -> iter_expression exp) priv;
+          List.iter (fun (_id, _, exp) -> iter_expression exp) priv;
           iter_class_expr cl
 
         | Tcl_apply (cl, args) ->
             iter_class_expr cl;
-            List.iter (fun (label, expo) ->
+            List.iter (fun (_label, expo) ->
                 match expo with
                   None -> ()
                 | Some exp -> iter_expression exp
@@ -495,10 +502,10 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
         | Tcl_let (rec_flat, bindings, ivars, cl) ->
           iter_bindings rec_flat bindings;
-          List.iter (fun (id, _, exp) -> iter_expression exp) ivars;
+          List.iter (fun (_id, _, exp) -> iter_expression exp) ivars;
             iter_class_expr cl
 
-        | Tcl_constraint (cl, Some clty, vals, meths, concrs) ->
+        | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
             iter_class_expr cl;
             iter_class_type clty
 
@@ -512,9 +519,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
       begin
         match ct.cltyp_desc with
           Tcty_signature csg -> iter_class_signature csg
-        | Tcty_constr (path, _, list) ->
+        | Tcty_constr (_path, _, list) ->
             List.iter iter_core_type list
-        | Tcty_arrow (label, ct, cl) ->
+        | Tcty_arrow (_label, ct, cl) ->
             iter_core_type ct;
             iter_class_type cl
       end;
@@ -532,9 +539,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
       begin
         match ctf.ctf_desc with
           Tctf_inherit ct -> iter_class_type ct
-        | Tctf_val (s, _mut, _virt, ct) ->
+        | Tctf_val (_s, _mut, _virt, ct) ->
             iter_core_type ct
-        | Tctf_method (s, _priv, _virt, ct) ->
+        | Tctf_method (_s, _priv, _virt, ct) ->
             iter_core_type ct
         | Tctf_constraint  (ct1, ct2) ->
             iter_core_type ct1;
@@ -548,22 +555,22 @@ module MakeIterator(Iter : IteratorArgument) : sig
       begin
         match ct.ctyp_desc with
           Ttyp_any -> ()
-        | Ttyp_var s -> ()
-        | Ttyp_arrow (label, ct1, ct2) ->
+        | Ttyp_var _ -> ()
+        | Ttyp_arrow (_label, ct1, ct2) ->
             iter_core_type ct1;
             iter_core_type ct2
         | Ttyp_tuple list -> List.iter iter_core_type list
-        | Ttyp_constr (path, _, list) ->
+        | Ttyp_constr (_path, _, list) ->
             List.iter iter_core_type list
-        | Ttyp_object (list, o) ->
+        | Ttyp_object (list, _o) ->
             List.iter (fun (_, _, t) -> iter_core_type t) list
-        | Ttyp_class (path, _, list) ->
+        | Ttyp_class (_path, _, list) ->
             List.iter iter_core_type list
-        | Ttyp_alias (ct, s) ->
+        | Ttyp_alias (ct, _s) ->
             iter_core_type ct
-        | Ttyp_variant (list, bool, labels) ->
+        | Ttyp_variant (list, _bool, _labels) ->
             List.iter iter_row_field list
-        | Ttyp_poly (list, ct) -> iter_core_type ct
+        | Ttyp_poly (_list, ct) -> iter_core_type ct
         | Ttyp_package pack -> iter_package_type pack
       end;
       Iter.leave_core_type ct
@@ -577,7 +584,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
     and iter_row_field rf =
       match rf with
-        Ttag (label, _attrs, bool, list) ->
+        Ttag (_label, _attrs, _bool, list) ->
           List.iter iter_core_type list
       | Tinherit ct -> iter_core_type ct
 
@@ -585,18 +592,18 @@ module MakeIterator(Iter : IteratorArgument) : sig
       Iter.enter_class_field cf;
       begin
         match cf.cf_desc with
-          Tcf_inherit (ovf, cl, super, _vals, _meths) ->
+          Tcf_inherit (_ovf, cl, _super, _vals, _meths) ->
           iter_class_expr cl
       | Tcf_constraint (cty, cty') ->
           iter_core_type cty;
           iter_core_type cty'
-      | Tcf_val (lab, _, _, Tcfk_virtual cty, _) ->
+      | Tcf_val (_lab, _, _, Tcfk_virtual cty, _) ->
           iter_core_type cty
-      | Tcf_val (lab, _, _, Tcfk_concrete (_, exp), _) ->
+      | Tcf_val (_lab, _, _, Tcfk_concrete (_, exp), _) ->
           iter_expression exp
-      | Tcf_method (lab, _, Tcfk_virtual cty) ->
+      | Tcf_method (_lab, _, Tcfk_virtual cty) ->
           iter_core_type cty
-      | Tcf_method (lab, _, Tcfk_concrete (_, exp)) ->
+      | Tcf_method (_lab, _, Tcfk_concrete (_, exp)) ->
           iter_expression exp
       | Tcf_initializer exp ->
           iter_expression exp

diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 46077aa314c66eb1566b20329e90cdd60380d37e..0695b2fe72d3dc16ae4816798d7c64648ffcf597 100644 (file)
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -94,7 +94,7 @@ module MakeMap(Map : MapArgument) = struct
       vb_loc = vb.vb_loc;
     }
 
-  and map_bindings rec_flag list =
+  and map_bindings list =
     List.map map_binding list
 
   and map_case {c_lhs; c_guard; c_rhs} =
@@ -113,7 +113,7 @@ module MakeMap(Map : MapArgument) = struct
       match item.str_desc with
           Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs)
         | Tstr_value (rec_flag, list) ->
-          Tstr_value (rec_flag, map_bindings rec_flag list)
+          Tstr_value (rec_flag, map_bindings list)
         | Tstr_primitive vd ->
           Tstr_primitive (map_value_description vd)
         | Tstr_type (rf, list) ->
@@ -259,7 +259,7 @@ module MakeMap(Map : MapArgument) = struct
     match pat_extra with
       | Tpat_constraint ct, loc, attrs ->
           (Tpat_constraint (map_core_type  ct), loc, attrs)
-      | (Tpat_type _ | Tpat_unpack), _, _ -> pat_extra
+      | (Tpat_type _ | Tpat_unpack | Tpat_open _ ), _, _ -> pat_extra
 
   and map_expression exp =
     let exp = Map.enter_expression exp in
@@ -269,7 +269,7 @@ module MakeMap(Map : MapArgument) = struct
         | Texp_constant _ -> exp.exp_desc
         | Texp_let (rec_flag, list, exp) ->
           Texp_let (rec_flag,
-                    map_bindings rec_flag list,
+                    map_bindings list,
                     map_expression exp)
         | Texp_function (label, cases, partial) ->
           Texp_function (label, map_cases cases, partial)
@@ -306,16 +306,19 @@ module MakeMap(Map : MapArgument) = struct
             | Some exp -> Some (map_expression exp)
           in
           Texp_variant (label, expo)
-        | Texp_record (list, expo) ->
-          let list =
-            List.map (fun (lid, lab_desc, exp) ->
-              (lid, lab_desc, map_expression exp)
-            ) list in
-          let expo = match expo with
-              None -> expo
+        | Texp_record { fields; representation; extended_expression } ->
+          let fields =
+            Array.map (function
+                | label, Kept t -> label, Kept t
+                | label, Overridden (lid, exp) ->
+                    label, Overridden (lid, map_expression exp))
+              fields
+          in
+          let extended_expression = match extended_expression with
+              None -> extended_expression
             | Some exp -> Some (map_expression exp)
           in
-          Texp_record (list, expo)
+          Texp_record { fields; representation; extended_expression }
         | Texp_field (exp, lid, label) ->
           Texp_field (map_expression exp, lid, label)
         | Texp_setfield (exp1, lid, label, exp2) ->
@@ -354,8 +357,8 @@ module MakeMap(Map : MapArgument) = struct
           )
         | Texp_send (exp, meth, expo) ->
           Texp_send (map_expression exp, meth, may_map map_expression expo)
-        | Texp_new (path, lid, cl_decl) -> exp.exp_desc
-        | Texp_instvar (_, path, _) -> exp.exp_desc
+        | Texp_new _ -> exp.exp_desc
+        | Texp_instvar _ -> exp.exp_desc
         | Texp_setinstvar (path, lid, path2, exp) ->
           Texp_setinstvar (path, lid, path2, map_expression exp)
         | Texp_override (path, list) ->
@@ -371,6 +374,11 @@ module MakeMap(Map : MapArgument) = struct
             map_module_expr mexpr,
             map_expression exp
           )
+        | Texp_letexception (cd, exp) ->
+          Texp_letexception (
+            map_extension_constructor cd,
+            map_expression exp
+          )
         | Texp_assert exp -> Texp_assert (map_expression exp)
         | Texp_lazy exp -> Texp_lazy (map_expression exp)
         | Texp_object (cl, string_list) ->
@@ -499,8 +507,8 @@ module MakeMap(Map : MapArgument) = struct
       match cstr with
           Twith_type decl -> Twith_type (map_type_declaration decl)
         | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
-        | Twith_module (path, lid) -> cstr
-        | Twith_modsubst (path, lid) -> cstr
+        | Twith_module _ -> cstr
+        | Twith_modsubst _ -> cstr
     in
     Map.leave_with_constraint cstr
 
@@ -508,7 +516,7 @@ module MakeMap(Map : MapArgument) = struct
     let mexpr = Map.enter_module_expr mexpr in
     let mod_desc =
       match mexpr.mod_desc with
-          Tmod_ident (p, lid) -> mexpr.mod_desc
+          Tmod_ident _ -> mexpr.mod_desc
         | Tmod_structure st -> Tmod_structure (map_structure st)
         | Tmod_functor (id, name, mtype, mexpr) ->
           Tmod_functor (id, name, Misc.may_map map_module_type mtype,
@@ -547,8 +555,8 @@ module MakeMap(Map : MapArgument) = struct
                      List.map (fun (label, expo) ->
                        (label, may_map map_expression expo)
                      ) args)
-        | Tcl_let (rec_flat, bindings, ivars, cl) ->
-          Tcl_let (rec_flat, map_bindings rec_flat bindings,
+        | Tcl_let (rec_flag, bindings, ivars, cl) ->
+          Tcl_let (rec_flag, map_bindings bindings,
                    List.map (fun (id, name, exp) ->
                      (id, name, map_expression exp)) ivars,
                    map_class_expr cl)

diff --git a/typing/typemod.ml b/typing/typemod.ml
index 1ea9bea8458c38f1a6eb22bc787b2d06340d8e14..0aa95e5dc3e48f98dd54a918afa554aa935557d7 100644 (file)
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -47,6 +47,13 @@ type error =
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
+module ImplementationHooks = Misc.MakeHooks(struct
+    type t = Typedtree.structure * Typedtree.module_coercion
+  end)
+module InterfaceHooks = Misc.MakeHooks(struct
+    type t = Typedtree.signature
+  end)
+
 open Typedtree
 
 let fst3 (x,_,_) = x
@@ -62,14 +69,14 @@ let rec path_concat head p =
 let extract_sig env loc mty =
   match Env.scrape_alias env mty with
     Mty_signature sg -> sg
-  | Mty_alias path ->
+  | Mty_alias(_, path) ->
       raise(Error(loc, env, Cannot_scrape_alias path))
   | _ -> raise(Error(loc, env, Signature_expected))
 
 let extract_sig_open env loc mty =
   match Env.scrape_alias env mty with
     Mty_signature sg -> sg
-  | Mty_alias path ->
+  | Mty_alias(_, path) ->
       raise(Error(loc, env, Cannot_scrape_alias path))
   | _ -> raise(Error(loc, env, Structure_expected mty))
 
@@ -104,7 +111,7 @@ let rm node =
 let type_module_type_of_fwd :
     (Env.t -> Parsetree.module_expr ->
       Typedtree.module_expr * Types.module_type) ref
-  = ref (fun env m -> assert false)
+  = ref (fun _env _m -> assert false)
 
 (* Merge one "with" constraint in a signature *)
 
@@ -139,10 +146,6 @@ let make p n i =
   let open Variance in
   set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
 
-let ensure_functor_arg p env =
-  if Env.is_functor_arg p env then env else
-  Env.add_functor_arg (Path.head p) env
-
 let merge_constraint initial_env loc sg constr =
   let lid =
     match constr with
@@ -181,6 +184,7 @@ let merge_constraint initial_env loc sg constr =
             type_newtype_level = None;
             type_attributes = [];
             type_immediate = false;
+            type_unboxed = unboxed_false_default_false;
           }
         and id_row = Ident.create (s^"#row") in
         let initial_env =
@@ -201,7 +205,7 @@ let merge_constraint initial_env loc sg constr =
         let newdecl = tdecl.typ_type in
         check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
         (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem
-    | (Sig_type(id, decl, rs) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
+    | (Sig_type(id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
       when Ident.name id = s ^ "#row" ->
         merge env rem namelist (Some id)
     | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl)
@@ -218,23 +222,21 @@ let merge_constraint initial_env loc sg constr =
       when Ident.name id = s ->
         let path, md' = Typetexp.find_module initial_env loc lid'.txt in
         let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in
-        let env = ensure_functor_arg path env in
-        let newmd = Mtype.strengthen_decl env md'' path in
+        let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
         ignore(Includemod.modtypes env newmd.md_type md.md_type);
         (Pident id, lid, Twith_module (path, lid')),
         Sig_module(id, newmd, rs) :: rem
     | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
       when Ident.name id = s ->
         let path, md' = Typetexp.find_module initial_env loc lid'.txt in
-        let env = ensure_functor_arg path env in
-        let newmd = Mtype.strengthen_decl env md' path in
+        let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in
         ignore(Includemod.modtypes env newmd.md_type md.md_type);
         real_id := Some id;
         (Pident id, lid, Twith_modsubst (path, lid')),
         update_rec_next rs rem
     | (Sig_module(id, md, rs) :: rem, s :: namelist, _)
       when Ident.name id = s ->
-        let ((path, path_loc, tcstr), newsg) =
+        let ((path, _path_loc, tcstr), newsg) =
           merge env (extract_sig env loc md.md_type) namelist None in
         (path_concat id path, lid, tcstr),
         Sig_module(id, {md with md_type=Mty_signature newsg}, rs) :: rem
@@ -248,7 +250,7 @@ let merge_constraint initial_env loc sg constr =
     let (tcstr, sg) = merge initial_env sg names None in
     let sg =
     match names, constr with
-      [s], Pwith_typesubst sdecl ->
+      [_], Pwith_typesubst sdecl ->
         let id =
           match !real_id with None -> assert false | Some id -> id in
         let lid =
@@ -266,12 +268,12 @@ let merge_constraint initial_env loc sg constr =
           with Exit ->
             raise(Error(sdecl.ptype_loc, initial_env, With_need_typeconstr))
         in
-        let (path, _) =
+        let path =
           try Env.lookup_type lid.txt initial_env with Not_found -> assert false
         in
         let sub = Subst.add_type id path Subst.identity in
         Subst.signature sub sg
-    | [s], Pwith_modsubst (_, lid) ->
+    | [_], Pwith_modsubst (_, lid) ->
         let id =
           match !real_id with None -> assert false | Some id -> id in
         let path = Typetexp.lookup_module initial_env loc lid.txt in
@@ -327,11 +329,11 @@ let map_ext fn exts rem =
 let rec approx_modtype env smty =
   match smty.pmty_desc with
     Pmty_ident lid ->
-      let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in
+      let (path, _info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in
       Mty_ident path
   | Pmty_alias lid ->
       let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in
-      Mty_alias path
+      Mty_alias(Mta_absent, path)
   | Pmty_signature ssg ->
       Mty_signature(approx_sig env ssg)
   | Pmty_functor(param, sarg, sres) ->
@@ -340,7 +342,7 @@ let rec approx_modtype env smty =
         Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in
       let res = approx_modtype newenv sres in
       Mty_functor(id, arg, res)
-  | Pmty_with(sbody, constraints) ->
+  | Pmty_with(sbody, _constraints) ->
       approx_modtype env sbody
   | Pmty_typeof smod ->
       let (_, mty) = !type_module_type_of_fwd env smod in
@@ -361,7 +363,7 @@ and approx_sig env ssg =
   | item :: srem ->
       match item.psig_desc with
       | Psig_type (rec_flag, sdecls) ->
-          let decls = Typedecl.approx_type_decl env sdecls in
+          let decls = Typedecl.approx_type_decl sdecls in
           let rem = approx_sig env srem in
           map_rec_type ~rec_flag
             (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem
@@ -381,7 +383,8 @@ and approx_sig env ssg =
           in
           let newenv =
             List.fold_left
-              (fun env (id, md) -> Env.add_module_declaration id md env)
+              (fun env (id, md) -> Env.add_module_declaration ~check:false
+                  id md env)
               env decls in
           map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls
                   (approx_sig newenv srem)
@@ -390,7 +393,7 @@ and approx_sig env ssg =
           let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
           Sig_modtype(id, info) :: approx_sig newenv srem
       | Psig_open sod ->
-          let (path, mty, _od) = type_open env sod in
+          let (_path, mty, _od) = type_open env sod in
           approx_sig mty srem
       | Psig_include sincl ->
           let smty = sincl.pincl_mod in
@@ -404,10 +407,11 @@ and approx_sig env ssg =
           let rem = approx_sig env srem in
           List.flatten
             (map_rec
-              (fun rs (i1, _, d1, i2, d2, i3, d3, _) ->
-                [Sig_class_type(i1, d1, rs);
-                 Sig_type(i2, d2, rs);
-                 Sig_type(i3, d3, rs)])
+               (fun rs decl ->
+                  let open Typeclass in
+                  [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                   Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                   Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
               decls [rem])
       | _ ->
           approx_sig env srem
@@ -437,7 +441,7 @@ let check_recmod_typedecls env sdecls decls =
 (* Auxiliaries for checking uniqueness of names in signatures and structures *)
 
 module StringSet =
-  Set.Make(struct type t = string let compare (x:t) y = compare x y end)
+  Set.Make(struct type t = string let compare (x:t) y = String.compare x y end)
 
 let check cl loc set_ref name =
   if StringSet.mem name !set_ref
@@ -483,7 +487,7 @@ let check_sig_item names loc = function
 let simplify_signature sg =
   let rec aux = function
     | [] -> [], StringSet.empty
-    | (Sig_value(id, descr) as component) :: sg ->
+    | (Sig_value(id, _descr) as component) :: sg ->
         let (sg, val_names) as k = aux sg in
         let name = Ident.name id in
         if StringSet.mem name val_names then k
@@ -498,7 +502,7 @@ let simplify_signature sg =
 (* Check and translate a module type expression *)
 
 let transl_modtype_longident loc env lid =
-  let (path, info) = Typetexp.find_modtype env loc lid in
+  let (path, _info) = Typetexp.find_modtype env loc lid in
   path
 
 let transl_module_alias loc env lid =
@@ -531,7 +535,7 @@ let rec transl_modtype env smty =
         smty.pmty_attributes
   | Pmty_alias lid ->
       let path = transl_module_alias loc env lid.txt in
-      mkmty (Tmty_alias (path, lid)) (Mty_alias path) env loc
+      mkmty (Tmty_alias (path, lid)) (Mty_alias(Mta_absent, path)) env loc
         smty.pmty_attributes
   | Pmty_signature ssg ->
       let sg = transl_signature env ssg in
@@ -644,7 +648,7 @@ and transl_signature env sg =
               (fun pmd -> check_name check_module names pmd.pmd_name)
               sdecls;
             let (decls, newenv) =
-              transl_recmodule_modtypes item.psig_loc env sdecls in
+              transl_recmodule_modtypes env sdecls in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_recmodule decls) env loc :: trem,
             map_rec (fun rs md ->
@@ -658,14 +662,14 @@ and transl_signature env sg =
         | Psig_modtype pmtd ->
             let newenv, mtd, sg =
               Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes
-                (fun () -> transl_modtype_decl names env item.psig_loc pmtd)
+                (fun () -> transl_modtype_decl names env pmtd)
             in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_modtype mtd) env loc :: trem,
             sg :: rem,
             final_env
         | Psig_open sod ->
-            let (path, newenv, od) = type_open env sod in
+            let (_path, newenv, od) = type_open env sod in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_open od) env loc :: trem,
             rem, final_env
@@ -698,19 +702,17 @@ and transl_signature env sg =
             let (classes, newenv) = Typeclass.class_descriptions env cl in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_class
-                     (List.map2
-                        (fun pcl tcl ->
-                          let (_, _, _, _, _, _, _, _, _, _, _, tcl) = tcl in
-                          tcl)
-                        cl classes)) env loc
+                     (List.map (fun decr ->
+                          decr.Typeclass.cls_info) classes)) env loc
             :: trem,
             List.flatten
               (map_rec
-                 (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) ->
-                   [Sig_class(i, d, rs);
-                    Sig_class_type(i', d', rs);
-                    Sig_type(i'', d'', rs);
-                    Sig_type(i''', d''', rs)])
+                 (fun rs cls ->
+                    let open Typeclass in
+                    [Sig_class(cls.cls_id, cls.cls_decl, rs);
+                     Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs);
+                     Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs);
+                     Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)])
                  classes [rem]),
             final_env
         | Psig_class_type cl ->
@@ -719,16 +721,16 @@ and transl_signature env sg =
               cl;
             let (classes, newenv) = Typeclass.class_type_declarations env cl in
             let (trem,rem, final_env) = transl_sig newenv srem in
-            mksig (Tsig_class_type (List.map2 (fun pcl tcl ->
-              let (_, _, _, _, _, _, _, tcl) = tcl in
-              tcl
-            ) cl classes)) env loc :: trem,
+            mksig (Tsig_class_type
+                     (List.map (fun decl -> decl.Typeclass.clsty_info) classes))
+              env loc :: trem,
             List.flatten
               (map_rec
-                 (fun rs (i, _, d, i', d', i'', d'', _) ->
-                   [Sig_class_type(i, d, rs);
-                    Sig_type(i', d', rs);
-                    Sig_type(i'', d'', rs)])
+                 (fun rs decl ->
+                    let open Typeclass in
+                    [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                     Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                     Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
                  classes [rem]),
             final_env
         | Psig_attribute x ->
@@ -748,7 +750,7 @@ and transl_signature env sg =
     ((Cmt_format.Partial_signature sg) :: previous_saved_types);
   sg
 
-and transl_modtype_decl names env loc
+and transl_modtype_decl names env
     {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
   check_name check_modtype names pmtd_name;
   let tmty = Misc.may_map (transl_modtype env) pmtd_type in
@@ -771,7 +773,7 @@ and transl_modtype_decl names env loc
   in
   newenv, mtd, Sig_modtype(id, decl)
 
-and transl_recmodule_modtypes loc env sdecls =
+and transl_recmodule_modtypes env sdecls =
   let make_env curr =
     List.fold_left
       (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env)
@@ -782,7 +784,7 @@ and transl_recmodule_modtypes loc env sdecls =
       env curr in
   let transition env_c curr =
     List.map2
-      (fun pmd (id, id_loc, mty) ->
+      (fun pmd (id, id_loc, _mty) ->
         let tmty =
           Builtin_attributes.with_warning_attribute pmd.pmd_attributes
             (fun () -> transl_modtype env_c pmd.pmd_type)
@@ -841,7 +843,7 @@ exception Not_a_path
 let rec path_of_module mexp =
   match mexp.mod_desc with
     Tmod_ident (p,_) -> p
-  | Tmod_apply(funct, arg, coercion) when !Clflags.applicative_functors ->
+  | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors ->
       Papply(path_of_module funct, path_of_module arg)
   | Tmod_constraint (mexp, _, _, _) ->
       path_of_module mexp
@@ -853,8 +855,8 @@ let path_of_module mexp =
 (* Check that all core type schemes in a structure are closed *)
 
 let rec closed_modtype env = function
-    Mty_ident p -> true
-  | Mty_alias p -> true
+    Mty_ident _ -> true
+  | Mty_alias _ -> true
   | Mty_signature sg ->
       let env = Env.add_signature sg env in
       List.for_all (closed_signature_item env) sg
@@ -863,8 +865,8 @@ let rec closed_modtype env = function
       closed_modtype env body
 
 and closed_signature_item env = function
-    Sig_value(id, desc) -> Ctype.closed_schema env desc.val_type
-  | Sig_module(id, md, _) -> closed_modtype env md.md_type
+    Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type
+  | Sig_module(_id, md, _) -> closed_modtype env md.md_type
   | _ -> true
 
 let check_nongen_scheme env sig_item =
@@ -884,7 +886,7 @@ let check_nongen_schemes env sg =
 
 let anchor_submodule name anchor =
   match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos))
-let anchor_recmodule id anchor =
+let anchor_recmodule id =
   Some (Pident id)
 
 let enrich_type_decls anchor decls oldenv newenv =
@@ -928,17 +930,15 @@ let check_recmodule_inclusion env bindings =
      the number of mutually recursive declarations. *)
 
   let subst_and_strengthen env s id mty =
-    let p = Subst.module_path s (Pident id) in
-    let env = ensure_functor_arg p env in
-    Mtype.strengthen env (Subst.modtype s mty) p
-  in
+    Mtype.strengthen ~aliasable:false env (Subst.modtype s mty)
+      (Subst.module_path s (Pident id)) in
 
   let rec check_incl first_time n env s =
     if n > 0 then begin
       (* Generate fresh names Y_i for the rec. bound module idents X_i *)
       let bindings1 =
         List.map
-          (fun (id, _, mty_decl, modl, mty_actual, _attrs, _loc) ->
+          (fun (id, _, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
              (id, Ident.rename id, mty_actual))
           bindings in
       (* Enter the Y_i in the environment with their actual types substituted
@@ -955,7 +955,7 @@ let check_recmodule_inclusion env bindings =
       (* Build the output substitution Y_i <- X_i *)
       let s' =
         List.fold_left
-          (fun s (id, id', mty_actual) ->
+          (fun s (id, id', _mty_actual) ->
              Subst.add_module id (Pident id') s)
           Subst.identity bindings1 in
       (* Recurse with env' and s' *)
@@ -1037,14 +1037,14 @@ let modtype_of_package env loc p nl tl =
 let package_subtype env p1 nl1 tl1 p2 nl2 tl2 =
   let mkmty p nl tl =
     let ntl =
-      List.filter (fun (n,t) -> Ctype.free_variables t = [])
+      List.filter (fun (_n,t) -> Ctype.free_variables t = [])
         (List.combine nl tl) in
     let (nl, tl) = List.split ntl in
     modtype_of_package env Location.none p nl tl
   in
   let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in
   try Includemod.modtypes env mty1 mty2 = Tcoerce_none
-  with Includemod.Error msg -> false
+  with Includemod.Error _msg -> false
     (* raise(Error(Location.none, env, Not_included msg)) *)
 
 let () = Ctype.package_subtype := package_subtype
@@ -1069,28 +1069,33 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod =
       let path =
         Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in
       let md = { mod_desc = Tmod_ident (path, lid);
-                 mod_type = Mty_alias path;
+                 mod_type = Mty_alias(Mta_absent, path);
                  mod_env = env;
                  mod_attributes = smod.pmod_attributes;
                  mod_loc = smod.pmod_loc } in
+      let aliasable = not (Env.is_functor_arg path env) in
       let md =
-        if alias && not (Env.is_functor_arg path env) then
+        if alias && aliasable then
           (Env.add_required_global (Path.head path); md)
         else match (Env.find_module path env).md_type with
-          Mty_alias p1 when not alias ->
+          Mty_alias(_, p1) when not alias ->
             let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
             let mty = Includemod.expand_module_alias env [] p1 in
             { md with
               mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit,
                                           Tcoerce_alias (p1, Tcoerce_none));
-              mod_type = if sttn then Mtype.strengthen env mty p1 else mty }
+              mod_type =
+                if sttn then Mtype.strengthen ~aliasable:true env mty p1
+                else mty }
         | mty ->
             let mty =
-              if sttn then Mtype.strengthen env mty path else mty in
+              if sttn then Mtype.strengthen ~aliasable env mty path
+              else mty
+            in
             { md with mod_type = mty }
       in rm md
   | Pmod_structure sstr ->
-      let (str, sg, finalenv) =
+      let (str, sg, _finalenv) =
         type_structure funct_body anchor env sstr smod.pmod_loc in
       let md =
         rm { mod_desc = Tmod_structure str;
@@ -1156,7 +1161,7 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod =
                mod_env = env;
                mod_attributes = smod.pmod_attributes;
                mod_loc = smod.pmod_loc }
-      | Mty_alias path ->
+      | Mty_alias(_, path) ->
           raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path))
       | _ ->
           raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type))
@@ -1316,8 +1321,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
           (fun (name, _, _, _, _) -> check_name check_module names name)
           sbind;
         let (decls, newenv) =
-          transl_recmodule_modtypes loc env
-            (List.map (fun (name, smty, smodl, attrs, loc) ->
+          transl_recmodule_modtypes env
+            (List.map (fun (name, smty, _smodl, attrs, loc) ->
                  {pmd_name=name; pmd_type=smty;
                   pmd_attributes=attrs; pmd_loc=loc}) sbind
             ) in
@@ -1327,7 +1332,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
                let modl =
                  Builtin_attributes.with_warning_attribute attrs
                    (fun () ->
-                      type_module true funct_body (anchor_recmodule id anchor)
+                      type_module true funct_body (anchor_recmodule id)
                         newenv smodl
                    )
                in
@@ -1346,7 +1351,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
                    md_loc = md.md_loc;
                  }
                in
-               Env.add_module_declaration md.md_id mdecl env
+               Env.add_module_declaration ~check:true md.md_id mdecl env
             )
             env decls
         in
@@ -1365,11 +1370,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         (* check that it is non-abstract *)
         let newenv, mtd, sg =
           Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes
-            (fun () -> transl_modtype_decl names env loc pmtd)
+            (fun () -> transl_modtype_decl names env pmtd)
         in
         Tstr_modtype mtd, [sg], newenv
     | Pstr_open sod ->
-        let (path, newenv, od) = type_open ~toplevel env sod in
+        let (_path, newenv, od) = type_open ~toplevel env sod in
         Tstr_open od, [], newenv
     | Pstr_class cl ->
         List.iter
@@ -1377,7 +1382,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
           cl;
         let (classes, new_env) = Typeclass.class_declarations env cl in
         Tstr_class
-          (List.map (fun (_,_,_,_,_,_,_,_,_,_, m, c) -> (c, m)) classes),
+          (List.map (fun cls ->
+               (cls.Typeclass.cls_info,
+                cls.Typeclass.cls_pub_methods)) classes),
 (* TODO: check with Jacques why this is here
       Tstr_class_type
           (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) ::
@@ -1388,11 +1395,12 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
 *)
         List.flatten
           (map_rec
-             (fun rs (i, _, d, i', d', i'', d'', i''', d''', _, _, _) ->
-                [Sig_class(i, d, rs);
-                 Sig_class_type(i', d', rs);
-                 Sig_type(i'', d'', rs);
-                 Sig_type(i''', d''', rs)])
+            (fun rs cls ->
+              let open Typeclass in
+              [Sig_class(cls.cls_id, cls.cls_decl, rs);
+               Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs);
+               Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs);
+               Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)])
              classes []),
         new_env
     | Pstr_class_type cl ->
@@ -1401,8 +1409,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
           cl;
         let (classes, new_env) = Typeclass.class_type_declarations env cl in
         Tstr_class_type
-          (List.map (fun (i, i_loc, d, _, _, _, _, c) ->
-               (i, i_loc, c)) classes),
+          (List.map (fun cl ->
+               (cl.Typeclass.clsty_ty_id,
+                cl.Typeclass.clsty_id_loc,
+                cl.Typeclass.clsty_info)) classes),
 (*  TODO: check with Jacques why this is here
            Tstr_type
              (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) ::
@@ -1410,10 +1420,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
              (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *)
         List.flatten
           (map_rec
-             (fun rs (i, _, d, i', d', i'', d'', _) ->
-                [Sig_class_type(i, d, rs);
-                 Sig_type(i', d', rs);
-                 Sig_type(i'', d'', rs)])
+             (fun rs decl ->
+                let open Typeclass in
+                [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs);
+                 Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs);
+                 Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)])
              classes []),
         new_env
     | Pstr_include sincl ->
@@ -1472,7 +1483,13 @@ let type_toplevel_phrase env s =
     let iter = Builtin_attributes.emit_external_warnings in
     iter.Ast_iterator.structure iter s
   end;
-  type_structure ~toplevel:true false None env s Location.none
+  let (str, sg, env) =
+    type_structure ~toplevel:true false None env s Location.none in
+  let (str, _coerce) = ImplementationHooks.apply_hooks
+      { Misc.sourcefile = "//toplevel//" } (str, Tcoerce_none)
+  in
+  (str, sg, env)
+
 let type_module_alias = type_module ~alias:true true false None
 let type_module = type_module true false None
 let type_structure = type_structure false None
@@ -1480,16 +1497,16 @@ let type_structure = type_structure false None
 (* Normalize types in a signature *)
 
 let rec normalize_modtype env = function
-    Mty_ident p -> ()
-  | Mty_alias p -> ()
+    Mty_ident _
+  | Mty_alias _ -> ()
   | Mty_signature sg -> normalize_signature env sg
-  | Mty_functor(id, param, body) -> normalize_modtype env body
+  | Mty_functor(_id, _param, body) -> normalize_modtype env body
 
 and normalize_signature env = List.iter (normalize_signature_item env)
 
 and normalize_signature_item env = function
-    Sig_value(id, desc) -> Ctype.normalize_type env desc.val_type
-  | Sig_module(id, md, _) -> normalize_modtype env md.md_type
+    Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type
+  | Sig_module(_id, md, _) -> normalize_modtype env md.md_type
   | _ -> ()
 
 (* Extract the module type of a module expression *)
@@ -1515,7 +1532,7 @@ let type_module_type_of env smod =
 
 (* For Typecore *)
 
-let type_package env m p nl tl =
+let type_package env m p nl =
   (* Same as Pexp_letmodule *)
   (* remember original level *)
   let lv = Ctype.get_current_level () in
@@ -1528,7 +1545,7 @@ let type_package env m p nl tl =
   let (mp, env) =
     match modl.mod_desc with
       Tmod_ident (mp,_) -> (mp, env)
-    | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, mty, Tmodtype_implicit, _)
+    | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _)
         -> (mp, env)  (* PR#6982 *)
     | _ ->
       let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in
@@ -1587,7 +1604,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
     (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
   end else begin
     let sourceintf =
-      Misc.chop_extension_if_any sourcefile ^ !Config.interface_suffix in
+      Filename.remove_extension sourcefile ^ !Config.interface_suffix in
     if Sys.file_exists sourceintf then begin
       let intf_file =
         try
@@ -1636,17 +1653,20 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       (Some sourcefile) initial_env None;
     raise e
 
+let type_implementation sourcefile outputprefix modulename initial_env ast =
+  ImplementationHooks.apply_hooks { Misc.sourcefile }
+    (type_implementation sourcefile outputprefix modulename initial_env ast)
 
 let save_signature modname tsg outputprefix source_file initial_env cmi =
   Cmt_format.save_cmt  (outputprefix ^ ".cmti") modname
     (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
 
-let type_interface env ast =
+let type_interface sourcefile env ast =
   begin
     let iter = Builtin_attributes.emit_external_warnings in
     iter.Ast_iterator.signature iter ast
   end;
-  transl_signature env ast
+  InterfaceHooks.apply_hooks { Misc.sourcefile } (transl_signature env ast)
 
 (* "Packaging" of several compilation units into one unit
    having them as sub-modules.  *)
@@ -1682,7 +1702,7 @@ let package_units initial_env objfiles cmifile modulename =
   Ident.reinit();
   let sg = package_signatures Subst.identity units in
   (* See if explicit interface is provided *)
-  let prefix = chop_extension_if_any cmifile in
+  let prefix = Filename.remove_extension cmifile in
   let mlifile = prefix ^ !Config.interface_suffix in
   if Sys.file_exists mlifile then begin
     if not (Sys.file_exists cmifile) then begin
@@ -1698,7 +1718,7 @@ let package_units initial_env objfiles cmifile modulename =
     let unit_names = List.map fst units in
     let imports =
       List.filter
-        (fun (name, crc) -> not (List.mem name unit_names))
+        (fun (name, _crc) -> not (List.mem name unit_names))
         (Env.imports()) in
     (* Write packaged signature *)
     if not !Clflags.dont_write_files then begin

diff --git a/typing/typemod.mli b/typing/typemod.mli
index 975a5a6852751e99e0b8f7252e280dc6673f5d52..40172bccbd34026ef7539a00af3ccdc47e74acac 100644 (file)
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -30,7 +30,7 @@ val type_implementation:
   string -> string -> string -> Env.t -> Parsetree.structure ->
   Typedtree.structure * Typedtree.module_coercion
 val type_interface:
-        Env.t -> Parsetree.signature -> Typedtree.signature
+        string -> Env.t -> Parsetree.signature -> Typedtree.signature
 val transl_signature:
         Env.t -> Parsetree.signature -> Typedtree.signature
 val check_nongen_schemes:
@@ -79,3 +79,9 @@ exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
 val report_error: Env.t -> formatter -> error -> unit
+
+
+module ImplementationHooks : Misc.HookSig
+  with type t = Typedtree.structure * Typedtree.module_coercion
+module InterfaceHooks : Misc.HookSig
+  with type t = Typedtree.signature

diff --git a/typing/types.ml b/typing/types.ml
index c90838104f53ef77ee130dad0bc575b74d7238fa..0e85644f0e53214da7f5a46c048c0928f8a936db 100644 (file)
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -149,6 +149,7 @@ type type_declaration =
     type_loc: Location.t;
     type_attributes: Parsetree.attributes;
     type_immediate: bool;
+    type_unboxed: unboxed_status;
  }
 
 and type_kind =
@@ -160,6 +161,7 @@ and type_kind =
 and record_representation =
     Record_regular                      (* All fields are boxed / tagged *)
   | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
   | Record_inlined of int               (* Inlined record *)
   | Record_extension                    (* Inlined record under extension *)
 
@@ -185,6 +187,17 @@ and constructor_arguments =
   | Cstr_tuple of type_expr list
   | Cstr_record of label_declaration list
 
+and unboxed_status =
+  {
+    unboxed: bool;
+    default: bool; (* False if the unboxed field was set from an attribute. *)
+  }
+
+let unboxed_false_default_false = {unboxed = false; default = false}
+let unboxed_false_default_true = {unboxed = false; default = true}
+let unboxed_true_default_false = {unboxed = true; default = false}
+let unboxed_true_default_true = {unboxed = true; default = true}
+
 type extension_constructor =
     { ext_type_path: Path.t;
       ext_type_params: type_expr list;
@@ -240,7 +253,11 @@ type module_type =
     Mty_ident of Path.t
   | Mty_signature of signature
   | Mty_functor of Ident.t * module_type option * module_type
-  | Mty_alias of Path.t
+  | Mty_alias of alias_presence * Path.t
+
+and alias_presence =
+  | Mta_present
+  | Mta_absent
 
 and signature = signature_item list
 
@@ -301,6 +318,7 @@ type constructor_description =
 and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
   | Cstr_extension of Path.t * bool     (* Extension constructor
                                            true if a constant false if a block*)
 

diff --git a/typing/types.mli b/typing/types.mli
index 45c9ddc6af15d98cdf3f79addc9c2c8dbf4f397e..2dc1481ee02d092f260a1d7061b4f1e141834233 100644 (file)
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -295,6 +295,7 @@ type type_declaration =
     type_loc: Location.t;
     type_attributes: Parsetree.attributes;
     type_immediate: bool; (* true iff type should not be a pointer *)
+    type_unboxed: unboxed_status;
   }
 
 and type_kind =
@@ -306,6 +307,7 @@ and type_kind =
 and record_representation =
     Record_regular                      (* All fields are boxed / tagged *)
   | Record_float                        (* All fields are floats *)
+  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
   | Record_inlined of int               (* Inlined record *)
   | Record_extension                    (* Inlined record under extension *)
 
@@ -331,6 +333,20 @@ and constructor_arguments =
   | Cstr_tuple of type_expr list
   | Cstr_record of label_declaration list
 
+and unboxed_status = private
+  (* This type must be private in order to ensure perfect sharing of the
+     four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce
+     different executables. *)
+  {
+    unboxed: bool;
+    default: bool; (* True for unannotated unboxable types. *)
+  }
+
+val unboxed_false_default_false : unboxed_status
+val unboxed_false_default_true : unboxed_status
+val unboxed_true_default_false : unboxed_status
+val unboxed_true_default_true : unboxed_status
+
 type extension_constructor =
     {
       ext_type_path: Path.t;
@@ -388,7 +404,11 @@ type module_type =
     Mty_ident of Path.t
   | Mty_signature of signature
   | Mty_functor of Ident.t * module_type option * module_type
-  | Mty_alias of Path.t
+  | Mty_alias of alias_presence * Path.t
+
+and alias_presence =
+  | Mta_present
+  | Mta_absent
 
 and signature = signature_item list
 
@@ -449,6 +469,7 @@ type constructor_description =
 and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
+  | Cstr_unboxed                        (* Constructor of an unboxed type *)
   | Cstr_extension of Path.t * bool     (* Extension constructor
                                            true if a constant false if a block*)
 

diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index a1ca6a12177a0b38c127cc5c7d8453cbd5f9cd40..e0d06dd13160a798527557836074c47a1d876360 100644 (file)
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -73,7 +73,7 @@ let instance_list = Ctype.instance_list Env.empty
 let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
   fun env loc lid make_error ->
   let check_module mlid =
-    try ignore (Env.lookup_module true mlid env) with
+    try ignore (Env.lookup_module ~load:true mlid env) with
     | Not_found ->
         narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid)
     | Env.Recmodule ->
@@ -83,28 +83,28 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
   | Longident.Lident _ -> ()
   | Longident.Ldot (mlid, _) ->
       check_module mlid;
-      let md = Env.find_module (Env.lookup_module true mlid env) env in
+      let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in
       begin match Env.scrape_alias env md.md_type with
       | Mty_functor _ ->
           raise (Error (loc, env, Access_functor_as_structure mlid))
-      | Mty_alias p ->
+      | Mty_alias(_, p) ->
           raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
       | _ -> ()
       end
   | Longident.Lapply (flid, mlid) ->
       check_module flid;
-      let fmd = Env.find_module (Env.lookup_module true flid env) env in
+      let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in
       begin match Env.scrape_alias env fmd.md_type with
       | Mty_signature _ ->
           raise (Error (loc, env, Apply_structure_as_functor flid))
-      | Mty_alias p ->
+      | Mty_alias(_, p) ->
           raise (Error (loc, env, Cannot_scrape_alias(flid, p)))
       | _ -> ()
       end;
       check_module mlid;
-      let mmd = Env.find_module (Env.lookup_module true mlid env) env in
+      let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in
       begin match Env.scrape_alias env mmd.md_type with
-      | Mty_alias p ->
+      | Mty_alias(_, p) ->
           raise (Error (loc, env, Cannot_scrape_alias(mlid, p)))
       | _ ->
           raise (Error (loc, env, Ill_typed_functor_application lid))
@@ -112,25 +112,26 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a =
   end;
   raise (Error (loc, env, make_error lid))
 
-let find_component lookup make_error env loc lid =
+let find_component (lookup : ?loc:_ -> _) make_error env loc lid =
   try
     match lid with
     | Longident.Ldot (Longident.Lident "*predef*", s) ->
-        lookup ?loc:(Some loc) (Longident.Lident s) Env.initial_safe_string
+        lookup ~loc (Longident.Lident s) Env.initial_safe_string
     | _ ->
-        lookup ?loc:(Some loc) lid env
+        lookup ~loc lid env
   with Not_found ->
     narrow_unbound_lid_error env loc lid make_error
   | Env.Recmodule ->
     raise (Error (loc, env, Illegal_reference_to_recursive_module))
 
 let find_type env loc lid =
-  let (path, decl) as r =
+  let path =
     find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
       env loc lid
   in
+  let decl = Env.find_type path env in
   Builtin_attributes.check_deprecated loc decl.type_attributes (Path.name path);
-  r
+  (path, decl)
 
 let find_constructor =
   find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
@@ -199,7 +200,7 @@ let transl_modtype = ref (fun _ -> assert false)
 let create_package_mty fake loc env (p, l) =
   let l =
     List.sort
-      (fun (s1, t1) (s2, t2) ->
+      (fun (s1, _t1) (s2, _t2) ->
          if s1.txt = s2.txt then
            raise (Error (loc, env, Multiple_constraints_on_type s1.txt));
          compare s1.txt s2.txt)
@@ -379,9 +380,10 @@ let rec transl_type env policy styp =
       let ty = newobj (transl_fields loc env policy [] o fields) in
       ctyp (Ttyp_object (fields, o)) ty
   | Ptyp_class(lid, stl) ->
-      let (path, decl, is_variant) =
+      let (path, decl, _is_variant) =
         try
-          let (path, decl) = Env.lookup_type lid.txt env in
+          let path = Env.lookup_type lid.txt env in
+          let decl = Env.find_type path env in
           let rec check decl =
             match decl.type_manifest with
               None -> raise Not_found
@@ -402,7 +404,8 @@ let rec transl_type env policy styp =
             | Longident.Ldot(r, s)   -> Longident.Ldot (r, "#" ^ s)
             | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type"
           in
-          let (path, decl) = Env.lookup_type lid2 env in
+          let path = Env.lookup_type lid2 env in
+          let decl = Env.find_type path env in
           (path, decl, false)
         with Not_found ->
           ignore (find_class env styp.ptyp_loc lid.txt); assert false
@@ -509,7 +512,7 @@ let rec transl_type env policy styp =
           let ty = mkfield l f and ty' = mkfield l f' in
           if equal env false [ty] [ty'] then () else
           try unify env ty ty'
-          with Unify trace ->
+          with Unify _trace ->
             raise(Error(loc, env, Constructor_mismatch (ty,ty')))
         with Not_found ->
           Hashtbl.add hfields h (l,f)
@@ -632,7 +635,7 @@ let rec transl_type env policy styp =
                           ) l in
       let path = !transl_modtype_longident styp.ptyp_loc env p.txt in
       let ty = newty (Tpackage (path,
-                       List.map (fun (s, pty) -> s.txt) l,
+                       List.map (fun (s, _pty) -> s.txt) l,
                        List.map (fun (_,cty) -> cty.ctyp_type) ptys))
       in
       ctyp (Ttyp_package {
@@ -673,7 +676,7 @@ let rec make_fixed_univars ty =
               {row with row_fixed=true;
                row_fields = List.map
                  (fun (s,f as p) -> match Btype.row_field_repr f with
-                   Reither (c, tl, m, r) -> s, Reither (c, tl, true, r)
+                   Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)
                  | _ -> p)
                  row.row_fields};
         Btype.iter_row make_fixed_univars row

diff --git a/typing/untypeast.ml b/typing/untypeast.ml
index 2f0c26d5dc7d4bf1e76bc92cb24da7dbdc062808..3b62145d2d29f4bc4ae40328918032997aab96a7 100644 (file)
--- a/typing/untypeast.ml
+++ b/typing/untypeast.ml
@@ -410,11 +410,13 @@ let expression sub exp =
           ))
     | Texp_variant (label, expo) ->
         Pexp_variant (label, map_opt (sub.expr sub) expo)
-    | Texp_record (list, expo) ->
-        Pexp_record (List.map (fun (lid, _, exp) ->
-              (map_loc sub lid, sub.expr sub exp)
-          ) list,
-          map_opt (sub.expr sub) expo)
+    | Texp_record { fields; extended_expression; _ } ->
+        let list = Array.fold_left (fun l -> function
+            | _, Kept _ -> l
+            | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
+            [] fields
+        in
+        Pexp_record (list, map_opt (sub.expr sub) extended_expression)
     | Texp_field (exp, lid, _label) ->
         Pexp_field (sub.expr sub exp, map_loc sub lid)
     | Texp_setfield (exp1, lid, _label, exp2) ->
@@ -450,6 +452,9 @@ let expression sub exp =
     | Texp_letmodule (_id, name, mexpr, exp) ->
         Pexp_letmodule (name, sub.module_expr sub mexpr,
           sub.expr sub exp)
+    | Texp_letexception (ext, exp) ->
+        Pexp_letexception (sub.extension_constructor sub ext,
+                           sub.expr sub exp)
     | Texp_assert exp -> Pexp_assert (sub.expr sub exp)
     | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
     | Texp_object (cl, _) ->
@@ -747,7 +752,7 @@ let class_field sub cf =
   in
   Cf.mk ~loc ~attrs desc
 
-let location sub l = l
+let location _sub l = l
 
 let default_mapper =
   {

diff --git a/utils/arg_helper.ml b/utils/arg_helper.ml
index 15061e33d8d28e4cc927cd39991f7a8bdf0b2065..fa80007ad497dd5f57c93dd2aaa98bc88a8ecc13 100644 (file)
--- a/utils/arg_helper.ml
+++ b/utils/arg_helper.ml
@@ -58,15 +58,12 @@ end) = struct
   let add_user_override key value t =
     { t with user_override = S.Key.Map.add key value t.user_override }
 
-  let no_equals value =
-    match String.index value '=' with
-    | exception Not_found -> true
-    | _index -> false
-
   exception Parse_failure of exn
 
   let parse_exn str ~update =
-    let values = Misc.Stdlib.String.split str ~on:',' in
+    (* Is the removal of empty chunks really relevant here? *)
+    (* (It has been added to mimic the old Misc.String.split.) *)
+    let values = String.split_on_char ',' str |> List.filter ((<>) "") in
     let parsed =
       List.fold_left (fun acc value ->
           match String.index value '=' with
@@ -101,7 +98,7 @@ end) = struct
     in
     update := parsed
 
-  let parse str ~help_text ~update =
+  let parse str help_text update =
     match parse_exn str ~update with
     | () -> ()
     | exception (Parse_failure exn) ->
@@ -111,7 +108,7 @@ end) = struct
     | Ok
     | Parse_failed of exn
 
-  let parse_no_error str ~update =
+  let parse_no_error str update =
     match parse_exn str ~update with
     | () -> Ok
     | exception (Parse_failure exn) -> Parse_failed exn

diff --git a/utils/arg_helper.mli b/utils/arg_helper.mli
index d877d755b778f2f32db707c987512f98da517e21..fba7aa2188605a43e5c497a6c3732ca15e01e5b5 100644 (file)
--- a/utils/arg_helper.mli
+++ b/utils/arg_helper.mli
@@ -51,13 +51,13 @@ end) : sig
 
   val add_user_override : S.Key.t -> S.Value.t -> parsed -> parsed
 
-  val parse : string -> help_text:string -> update:parsed ref -> unit
+  val parse : string -> string -> parsed ref -> unit
 
   type parse_result =
     | Ok
     | Parse_failed of exn
 
-  val parse_no_error : string -> update:parsed ref -> parse_result
+  val parse_no_error : string -> parsed ref -> parse_result
 
   val get : key:S.Key.t -> parsed -> S.Value.t
 end

diff --git a/utils/clflags.ml b/utils/clflags.ml
index b8ce959bf13d2d5f8a853143e90f41d03b9a9685..bd884872bce990c699df6c5b5e048f6ff3db9f92 100644 (file)
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -67,6 +67,7 @@ and use_threads = ref false             (* -thread *)
 and use_vmthreads = ref false           (* -vmthread *)
 and noassert = ref false                (* -noassert *)
 and verbose = ref false                 (* -verbose *)
+and noversion = ref false               (* -no-version *)
 and noprompt = ref false                (* -noprompt *)
 and nopromptcont = ref false            (* -nopromptcont *)
 and init_file = ref (None : string option)   (* -init *)
@@ -152,7 +153,8 @@ let runtime_variant = ref "";;      (* -runtime-variant *)
 
 let keep_docs = ref false              (* -keep-docs *)
 let keep_locs = ref false              (* -keep-locs *)
-let unsafe_string = ref true;;         (* -safe-string / -unsafe-string *)
+let unsafe_string = ref (not Config.safe_string)
+                                   (* -safe-string / -unsafe-string *)
 
 let classic_inlining = ref false       (* -Oclassic *)
 let inlining_report = ref false    (* -inlining-report *)
@@ -354,3 +356,5 @@ let parse_color_setting = function
   | "never" -> Some Misc.Color.Never
   | _ -> None
 let color = ref Misc.Color.Auto ;; (* -color *)
+
+let unboxed_types = ref false

diff --git a/utils/clflags.mli b/utils/clflags.mli
index a5c9ec9bd64facddc39848bffd00ee8ac47ac502..f7939eb6e9e4d5c252eff433799dea08cdec0b71 100644 (file)
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -17,12 +17,12 @@
 module Int_arg_helper : sig
   type parsed
 
-  val parse : string -> help_text:string -> update:parsed ref -> unit
+  val parse : string -> string -> parsed ref -> unit
 
   type parse_result =
     | Ok
     | Parse_failed of exn
-  val parse_no_error : string -> update:parsed ref -> parse_result
+  val parse_no_error : string -> parsed ref -> parse_result
 
   val get : key:int -> parsed -> int
 end
@@ -31,12 +31,12 @@ end
 module Float_arg_helper : sig
   type parsed
 
-  val parse : string -> help_text:string -> update:parsed ref -> unit
+  val parse : string -> string -> parsed ref -> unit
 
   type parse_result =
     | Ok
     | Parse_failed of exn
-  val parse_no_error : string -> update:parsed ref -> parse_result
+  val parse_no_error : string -> parsed ref -> parse_result
 
   val get : key:int -> parsed -> float
 end
@@ -97,6 +97,7 @@ val noprompt : bool ref
 val nopromptcont : bool ref
 val init_file : string option ref
 val noinit : bool ref
+val noversion : bool ref
 val use_prims : string ref
 val use_runtime : string ref
 val principal : bool ref
@@ -199,3 +200,5 @@ val set_dumped_pass : string -> bool -> unit
 
 val parse_color_setting : string -> Misc.Color.setting option
 val color : Misc.Color.setting ref
+
+val unboxed_types : bool ref

diff --git a/utils/config.mli b/utils/config.mli
index c8feca6a3933ceaba85d112d76212262b5bbe221..9b05005673a2128dc6ab1ec49403085783742302 100644 (file)
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -138,3 +138,16 @@ val print_config : out_channel -> unit;;
 
 val flambda : bool
         (* Whether the compiler was configured for flambda *)
+
+val spacetime : bool
+        (* Whether the compiler was configured for Spacetime profiling *)
+val profinfo_width : int
+        (* How many bits are to be used in values' headers for profiling
+           information *)
+val libunwind_available : bool
+        (* Whether the libunwind library is available on the target *)
+val libunwind_link_flags : string
+        (* Linker flags to use libunwind *)
+
+val safe_string: bool
+        (* Whether the compiler was configured with -safe-string *)

diff --git a/utils/config.mlp b/utils/config.mlp
index df9c0c81793f35b6cd4d5feddc3523d8e1d1d49e..e821ef07e298a48befeb60393ff32bc54019cd28 100644 (file)
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -1,3 +1,4 @@
+#2 "utils/config.mlp"
 (**************************************************************************)
 (*                                                                        *)
 (*                                 OCaml                                  *)
@@ -67,9 +68,10 @@ let mkdll, mkexe, mkmaindll =
     "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
 
 let flambda = %%FLAMBDA%%
+let safe_string = %%SAFE_STRING%%
 
 let exec_magic_number = "Caml1999X011"
-and cmi_magic_number = "Caml1999I020"
+and cmi_magic_number = "Caml1999I021"
 and cmo_magic_number = "Caml1999O011"
 and cma_magic_number = "Caml1999A012"
 and cmx_magic_number =
@@ -82,10 +84,10 @@ and cmxa_magic_number =
     "Caml1999Z015"
   else
     "Caml1999Z014"
-and ast_impl_magic_number = "Caml1999M019"
+and ast_impl_magic_number = "Caml1999M020"
 and ast_intf_magic_number = "Caml1999N018"
 and cmxs_magic_number = "Caml2007D002"
-and cmt_magic_number = "Caml2012T007"
+and cmt_magic_number = "Caml2012T008"
 
 let load_path = ref ([] : string list)
 
@@ -108,6 +110,10 @@ let system = "%%SYSTEM%%"
 let asm = "%%ASM%%"
 let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
 let with_frame_pointers = %%WITH_FRAME_POINTERS%%
+let spacetime = %%WITH_SPACETIME%%
+let libunwind_available = %%LIBUNWIND_AVAILABLE%%
+let libunwind_link_flags = "%%LIBUNWIND_LINK_FLAGS%%"
+let profinfo_width = %%PROFINFO_WIDTH%%
 
 let ext_obj = "%%EXT_OBJ%%"
 let ext_asm = "%%EXT_ASM%%"
@@ -156,6 +162,8 @@ let print_config oc =
   p "host" host;
   p "target" target;
   p_bool "flambda" flambda;
+  p_bool "spacetime" spacetime;
+  p_bool "safe_string" safe_string;
 
   (* print the magic number *)
   p "exec_magic_number" exec_magic_number;

diff --git a/utils/consistbl.ml b/utils/consistbl.ml
index b9be8ecac59d744253cd9114357997d214acb67a..dbba5d1f5a3f01faac084715705dd05a46ff2c94 100644 (file)
--- a/utils/consistbl.ml
+++ b/utils/consistbl.ml
@@ -57,7 +57,7 @@ let extract l tbl =
 let filter p tbl =
   let to_remove = ref [] in
   Hashtbl.iter
-    (fun name (crc, auth) ->
+    (fun name _ ->
       if not (p name) then to_remove := name :: !to_remove)
     tbl;
   List.iter

diff --git a/utils/identifiable.ml b/utils/identifiable.ml
index 4ff649af71b3167137a346e6608a641003e859b8..0a2f3be9bc0adb2ab730dd8df9d6e0a2f4ceb653 100644 (file)
--- a/utils/identifiable.ml
+++ b/utils/identifiable.ml
@@ -66,7 +66,7 @@ module Make_map (T : Thing) = struct
       m1 m2
 
   let union_right m1 m2 =
-    merge (fun id x y -> match x, y with
+    merge (fun _id x y -> match x, y with
         | None, None -> None
         | None, Some v
         | Some v, None
@@ -104,6 +104,17 @@ module Make_map (T : Thing) = struct
   let of_set f set = T_set.fold (fun e map -> add e (f e) map) set empty
 
   let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty
+  let transpose_keys_and_data_set map =
+    fold (fun k v m ->
+        let set =
+          match find v m with
+          | exception Not_found ->
+            T_set.singleton k
+          | set ->
+            T_set.add k set
+        in
+        add v set m)
+      map empty
 end
 
 module Make_set (T : Thing) = struct
@@ -194,6 +205,7 @@ module type S = sig
     val data : 'a t -> 'a list
     val of_set : (key -> 'a) -> Make_set (T).t -> 'a t
     val transpose_keys_and_data : key t -> key t
+    val transpose_keys_and_data_set : key t -> Set.t t
     val print :
       (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
   end

diff --git a/utils/identifiable.mli b/utils/identifiable.mli
index b47ce6afcbaa2c80329fef532ab0150230406329..255a6a59038627ce4938d69298eedbc990417c26 100644 (file)
--- a/utils/identifiable.mli
+++ b/utils/identifiable.mli
@@ -73,6 +73,7 @@ module type S = sig
     val data : 'a t -> 'a list
     val of_set : (key -> 'a) -> Set.t -> 'a t
     val transpose_keys_and_data : key t -> key t
+    val transpose_keys_and_data_set : key t -> Set.t t
     val print :
       (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
   end

diff --git a/utils/misc.ml b/utils/misc.ml
index 5e9d7e4636138ad90134194b00ef3a4e30dd219e..8ff77775aaf7c508e0b5eeae2fee77e8af44619a 100644 (file)
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -30,6 +30,17 @@ let try_finally work cleanup =
   result
 ;;
 
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+let protect_refs =
+  let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
+  fun refs f ->
+    let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
+    set_refs refs;
+    match f () with
+    | x           -> set_refs backup; x
+    | exception e -> set_refs backup; raise e
+
 (* List functions *)
 
 let rec map_end f l1 l2 =
@@ -63,24 +74,6 @@ let rec split_last = function
       (hd :: lst, last)
 
 module Stdlib = struct
-  module String = struct
-    type t = string
-
-    let split s ~on =
-      let is_separator c = (c = on) in
-      let rec split1 res i =
-        if i >= String.length s then res else begin
-          if is_separator s.[i] then split1 res (i+1)
-          else split2 res i (i+1)
-        end
-      and split2 res i j =
-        if j >= String.length s then String.sub s i (j-i) :: res else begin
-          if is_separator s.[j] then split1 (String.sub s i (j-i) :: res) (j+1)
-          else split2 res i (j+1)
-        end
-      in List.rev (split1 [] 0)
-  end
-
   module List = struct
     type 'a t = 'a list
 
@@ -115,7 +108,7 @@ module Stdlib = struct
       let rec aux acc l1 l2 =
         match l1, l2 with
         | [], _ -> (List.rev acc, l2)
-        | h::t, [] -> raise (Invalid_argument "map2_prefix")
+        | _ :: _, [] -> raise (Invalid_argument "map2_prefix")
         | h1::t1, h2::t2 ->
           let h = f h1 h2 in
           aux (h :: acc) t1 t2
@@ -221,7 +214,7 @@ let remove_file filename =
   try
     if Sys.file_exists filename
     then Sys.remove filename
-  with Sys_error msg ->
+  with Sys_error _msg ->
     ()
 
 (* Expand a -I option: if it starts with +, make it relative to the standard
@@ -298,9 +291,6 @@ end
 
 (* String operations *)
 
-let chop_extension_if_any fname =
-  try Filename.chop_extension fname with Invalid_argument _ -> fname
-
 let chop_extensions file =
   let dirname = Filename.dirname file and basename = Filename.basename file in
   try
@@ -484,22 +474,6 @@ let did_you_mean ppf get_choices =
        (if rest = [] then "" else " or ")
        last
 
-(* split a string [s] at every char [c], and return the list of sub-strings *)
-let split s c =
-  let len = String.length s in
-  let rec iter pos to_rev =
-    if pos = len then List.rev ("" :: to_rev) else
-      match try
-              Some ( String.index_from s pos c )
-        with Not_found -> None
-      with
-          Some pos2 ->
-            if pos2 = pos then iter (pos+1) ("" :: to_rev) else
-              iter (pos2+1) ((String.sub s pos (pos2-pos)) :: to_rev)
-        | None -> List.rev ( String.sub s pos (len-pos) :: to_rev )
-  in
-  iter 0 []
-
 let cut_at s c =
   let pos = String.index s c in
   String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1)
@@ -641,3 +615,82 @@ let normalise_eol s =
       if s.[i] <> '\r' then Buffer.add_char b s.[i]
     done;
     Buffer.contents b
+
+let delete_eol_spaces src =
+  let len_src = String.length src in
+  let dst = Bytes.create len_src in
+  let rec loop i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces 1 (i_src + 1) i_dst
+      | c ->
+        Bytes.set dst i_dst c;
+        loop (i_src + 1) (i_dst + 1)
+  and loop_spaces spaces i_src i_dst =
+    if i_src = len_src then
+      i_dst
+    else
+      match src.[i_src] with
+      | ' ' | '\t' ->
+        loop_spaces (spaces + 1) (i_src + 1) i_dst
+      | '\n' ->
+        Bytes.set dst i_dst '\n';
+        loop (i_src + 1) (i_dst + 1)
+      | _ ->
+        for n = 0 to spaces do
+          Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
+        done;
+        loop (i_src + 1) (i_dst + spaces + 1)
+  in
+  let stop = loop 0 0 in
+  Bytes.sub_string dst 0 stop
+
+type hook_info = {
+  sourcefile : string;
+}
+
+exception HookExnWrapper of
+    {
+      error: exn;
+      hook_name: string;
+      hook_info: hook_info;
+    }
+
+exception HookExn of exn
+
+let raise_direct_hook_exn e = raise (HookExn e)
+
+let fold_hooks list hook_info ast =
+  List.fold_left (fun ast (hook_name,f) ->
+    try
+      f hook_info ast
+    with
+    | HookExn e -> raise e
+    | error -> raise (HookExnWrapper {error; hook_name; hook_info})
+       (* when explicit reraise with backtrace will be available,
+          it should be used here *)
+
+  ) ast (List.sort compare list)
+
+module type HookSig = sig
+  type t
+
+  val add_hook : string -> (hook_info -> t -> t) -> unit
+  val apply_hooks : hook_info -> t -> t
+end
+
+module MakeHooks(M: sig
+    type t
+  end) : HookSig with type t = M.t
+= struct
+
+  type t = M.t
+
+  let hooks = ref []
+  let add_hook name f = hooks := (name, f) :: !hooks
+  let apply_hooks sourcefile intf =
+    fold_hooks !hooks sourcefile intf
+end

diff --git a/utils/misc.mli b/utils/misc.mli
index be5d23c2ee16a4b6bc0f5256e1a4a53ad5b104ee..bdcbae95399c060bcf6bb42c5d6c4474cf5d51ae 100644 (file)
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -40,6 +40,13 @@ val split_last: 'a list -> 'a list * 'a
 val may: ('a -> unit) -> 'a option -> unit
 val may_map: ('a -> 'b) -> 'a option -> 'b option
 
+type ref_and_value = R : 'a ref * 'a -> ref_and_value
+
+val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
+(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
+    while executing [f]. The previous contents of the references is restored
+    even if [f] raises an exception. *)
+
 module Stdlib : sig
   module List : sig
     type 'a t = 'a list
@@ -83,15 +90,6 @@ module Stdlib : sig
     val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
     val value_default : ('a -> 'b) -> default:'b -> 'a t -> 'b
   end
-
-  module String : sig
-    type t = string
-
-    val split : t -> on:char -> t list
-    (** Splits the given string at every occurrence of the given separator.
-        Does not return empty substrings when the separator is repeated or
-        present at the start or end of the string. *)
-  end
 end
 
 val find_in_path: string list -> string -> string
@@ -148,10 +146,6 @@ module Int_literal_converter : sig
   val nativeint : string -> nativeint
 end
 
-val chop_extension_if_any: string -> string
-        (* Like Filename.chop_extension but returns the initial file
-           name if it has no extension *)
-
 val chop_extensions: string -> string
         (* Return the given file name without its extensions. The extensions
            is the longest suffix starting with a period and not including
@@ -232,13 +226,6 @@ val did_you_mean : Format.formatter -> (unit -> string list) -> unit
     the failure even if producing the hint is slow.
 *)
 
-val split : string -> char -> string list
-(** [String.split string char] splits the string [string] at every char
-    [char], and returns the list of sub-strings between the chars.
-    [String.concat (String.make 1 c) (String.split s c)] is the identity.
-    @since 4.01
- *)
-
 val cut_at : string -> char -> string * string
 (** [String.cut_at s c] returns a pair containing the sub-string before
    the first occurrence of [c] in [s], and the sub-string after the
@@ -303,3 +290,44 @@ val normalise_eol : string -> string
 (** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
    removed. Intended for pre-processing text which will subsequently be printed
    on a channel which performs EOL transformations (i.e. Windows) *)
+
+val delete_eol_spaces : string -> string
+(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of
+   line spaces removed. Intended to normalize the output of the
+   toplevel for tests. *)
+
+
+
+(** {2 Hook machinery} *)
+
+(* Hooks machinery:
+   [add_hook name f] will register a function that will be called on the
+    argument of a later call to [apply_hooks]. Hooks are applied in the
+    lexicographical order of their names.
+*)
+
+type hook_info = {
+  sourcefile : string;
+}
+
+exception HookExnWrapper of
+    {
+      error: exn;
+      hook_name: string;
+      hook_info: hook_info;
+    }
+    (** An exception raised by a hook will be wrapped into a
+        [HookExnWrapper] constructor by the hook machinery.  *)
+
+
+val raise_direct_hook_exn: exn -> 'a
+  (** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will
+      not be wrapped into a [HookExnWrapper]. *)
+
+module type HookSig = sig
+  type t
+  val add_hook : string -> (hook_info -> t -> t) -> unit
+  val apply_hooks : hook_info -> t -> t
+end
+
+module MakeHooks : functor (M : sig type t end) -> HookSig with type t = M.t

diff --git a/utils/strongly_connected_components.ml b/utils/strongly_connected_components.ml
index ba9b45467c7afdc9377a1680676cf9271497b57e..a11f6987f4d9c6100c94ff26fd1701de278c0cc9 100644 (file)
--- a/utils/strongly_connected_components.ml
+++ b/utils/strongly_connected_components.ml
@@ -131,7 +131,8 @@ module Make (Id : Identifiable.S) = struct
     | No_loop of Id.t
 
   (* Ensure that the dependency graph does not have external dependencies. *)
-  let check dependencies =
+  (* Note: this function is currently not used. *)
+  let _check dependencies =
     Id.Map.iter (fun id set ->
         Id.Set.iter (fun v ->
             if not (Id.Map.mem v dependencies)

diff --git a/utils/tbl.ml b/utils/tbl.ml
index 4b03fe62556c4e2efedcf20d48767c3fa5a1ce63..abb7309b948fdf61c8d1415275f3674d9bc4eed2 100644 (file)
--- a/utils/tbl.ml
+++ b/utils/tbl.ml
@@ -68,7 +68,7 @@ let rec find x = function
 
 let rec mem x = function
     Empty -> false
-  | Node(l, v, d, r, _) ->
+  | Node(l, v, _d, r, _) ->
       let c = compare x v in
       c = 0 || mem x (if c < 0 then l else r)
 
@@ -76,13 +76,13 @@ let rec merge t1 t2 =
   match (t1, t2) with
     (Empty, t) -> t
   | (t, Empty) -> t
-  | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
+  | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) ->
       bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)
 
 let rec remove x = function
     Empty ->
       Empty
-  | Node(l, v, d, r, h) ->
+  | Node(l, v, d, r, _h) ->
       let c = compare x v in
       if c = 0 then
         merge l r

diff --git a/utils/warnings.ml b/utils/warnings.ml
index 6a22cf0b454e4fe4d7f37ec8dd242c29dca22f98..f2e08580f22a14dcc82269ddeece351cf3dba3a1 100644 (file)
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -14,10 +14,10 @@
 (**************************************************************************)
 
 (* When you change this, you need to update the documentation:
-   - man/ocamlc.m   in ocaml
-   - man/ocamlopt.m in ocaml
-   - manual/cmds/comp.etex   in the doc sources
-   - manual/cmds/native.etex in the doc sources
+   - man/ocamlc.m
+   - man/ocamlopt.m
+   - manual/manual/cmds/comp.etex
+   - manual/manual/cmds/native.etex
 *)
 
 type t =
@@ -58,7 +58,7 @@ type t =
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
   | Unused_constructor of string * bool * bool  (* 37 *)
-  | Unused_extension of string * bool * bool    (* 38 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
   | Unused_rec_flag                         (* 39 *)
   | Name_out_of_scope of string * string list * bool (* 40 *)
   | Ambiguous_name of string list * string list *  bool    (* 41 *)
@@ -80,6 +80,8 @@ type t =
   | Ambiguous_pattern of string list        (* 57 *)
   | No_cmx_file of string                   (* 58 *)
   | Assignment_to_non_mutable_value         (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -148,9 +150,11 @@ let number = function
   | Ambiguous_pattern _ -> 57
   | No_cmx_file _ -> 58
   | Assignment_to_non_mutable_value -> 59
+  | Unused_module _ -> 60
+  | Unboxable_type_in_prim_decl _ -> 61
 ;;
 
-let last_warning_number = 59
+let last_warning_number = 61
 ;;
 
 (* Must be the max number returned by the [number] function. *)
@@ -239,7 +243,7 @@ let parse_opt error active flags s =
     | '+' -> loop_letter_num set (i+1)
     | '-' -> loop_letter_num clear (i+1)
     | '@' -> loop_letter_num set_all (i+1)
-    | c -> error ()
+    | _ -> error ()
   and loop_letter_num myset i =
     if i >= String.length s then error () else
     match s.[i] with
@@ -265,7 +269,7 @@ let parse_options errflag s =
   current := {error; active}
 
 (* If you change these, don't forget to change them in man/ocamlc.m *)
-let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50";;
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50-60";;
 let defaults_warn_error = "-a+31";;
 
 let () = parse_options false defaults_w;;
@@ -306,7 +310,7 @@ let message = function
   | Partial_match "" -> "this pattern-matching is not exhaustive."
   | Partial_match s ->
       "this pattern-matching is not exhaustive.\n\
-       Here is an example of a value that is not matched:\n" ^ s
+       Here is an example of a case that is not matched:\n" ^ s
   | Non_closed_record_pattern s ->
       "the following labels are not bound in this record pattern:\n" ^ s ^
       "\nEither bind these labels explicitly or add '; _' to the pattern."
@@ -369,16 +373,21 @@ let message = function
       "constructor " ^ s ^
       " is never used to build values.\n\
         Its type is exported as a private type."
-  | Unused_extension (s, false, false) ->
-      "unused extension constructor " ^ s ^ "."
-  | Unused_extension (s, true, _) ->
-      "extension constructor " ^ s ^
-      " is never used to build values.\n\
-        (However, this constructor appears in patterns.)"
-  | Unused_extension (s, false, true) ->
-      "extension constructor " ^ s ^
-      " is never used to build values.\n\
-        It is exported or rebound as a private extension."
+  | Unused_extension (s, is_exception, cu_pattern, cu_privatize) ->
+     let kind =
+       if is_exception then "exception" else "extension constructor" in
+     let name = kind ^ " " ^ s in
+     begin match cu_pattern, cu_privatize with
+       | false, false -> "unused " ^ name
+       | true, _ ->
+          name ^
+          " is never used to build values.\n\
+           (However, this constructor appears in patterns.)"
+       | false, true ->
+          name ^
+          " is never used to build values.\n\
+            It is exported or rebound as a private extension."
+     end
   | Unused_rec_flag ->
       "unused rec flag."
   | Name_out_of_scope (ty, [nm], false) ->
@@ -395,12 +404,13 @@ let message = function
       s ^ " belongs to several types: " ^ String.concat " " tl ^
       "\nThe first one was selected. Please disambiguate if this is wrong."
   | Ambiguous_name (_, _, false) -> assert false
-  | Ambiguous_name (slist, tl, true) ->
+  | Ambiguous_name (_slist, tl, true) ->
       "these field labels belong to several types: " ^
       String.concat " " tl ^
       "\nThe first one was selected. Please disambiguate if this is wrong."
   | Disambiguated_name s ->
-      "this use of " ^ s ^ " required disambiguation."
+      "this use of " ^ s ^ " relies on type-directed disambiguation,\n\
+       it will not compile with OCaml 4.00 or earlier."
   | Nonoptional_label s ->
       "the label " ^ s ^ " is not optional."
   | Open_shadow_identifier (kind, s) ->
@@ -432,9 +442,9 @@ let message = function
       Printf.sprintf "expected tailcall"
   | Fragile_literal_pattern ->
       Printf.sprintf
-        "the argument of this constructor should not be matched against a\n\
-         constant pattern; the actual value of the argument could change\n\
-         in the future."
+        "Code should not depend on the actual values of\n\
+         this constructor's arguments. They are only for information\n\
+         and may change in future versions. (See manual section 8.5)"
   | Unreachable_case ->
       "this match case is unreachable.\n\
        Consider replacing it with a refutation case '<pat> -> .'"
@@ -466,6 +476,13 @@ let message = function
       "A potential assignment to a non-mutable value was detected \n\
         in this source file.  Such assignments may generate incorrect code \n\
         when using Flambda."
+  | Unused_module s -> "unused module " ^ s ^ "."
+  | Unboxable_type_in_prim_decl t ->
+      Printf.sprintf
+        "This primitive declaration uses type %s, which is unannotated and\n\
+         unboxable. The representation of such types may change in future\n\
+         versions. You should annotate the declaration of %s with [@@boxed]\n\
+         or [@@unboxed]." t t
 ;;
 
 let nerrors = ref 0;;
@@ -547,7 +564,7 @@ let descriptions =
    39, "Unused rec flag.";
    40, "Constructor or label name used out of scope.";
    41, "Ambiguous constructor or label name.";
-   42, "Disambiguated constructor or label name.";
+   42, "Disambiguated constructor or label name (compatibility warning).";
    43, "Nonoptional label applied as optional.";
    44, "Open statement shadows an already defined identifier.";
    45, "Open statement shadows an already defined label or constructor.";
@@ -565,6 +582,7 @@ let descriptions =
    57, "Ambiguous or-pattern variables under guard";
    58, "Missing cmx file";
    59, "Assignment to non-mutable value";
+   60, "Unused module declaration";
   ]
 ;;
 

diff --git a/utils/warnings.mli b/utils/warnings.mli
index adb91a07f46e5b41278d9181cea643380e38a226..fb03935b8f03d028dcccaa71f372d4da06b672cc 100644 (file)
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -53,7 +53,7 @@ type t =
   | Unused_for_index of string              (* 35 *)
   | Unused_ancestor of string               (* 36 *)
   | Unused_constructor of string * bool * bool (* 37 *)
-  | Unused_extension of string * bool * bool   (* 38 *)
+  | Unused_extension of string * bool * bool * bool (* 38 *)
   | Unused_rec_flag                         (* 39 *)
   | Name_out_of_scope of string * string list * bool   (* 40 *)
   | Ambiguous_name of string list * string list * bool (* 41 *)
@@ -75,6 +75,8 @@ type t =
   | Ambiguous_pattern of string list        (* 57 *)
   | No_cmx_file of string                   (* 58 *)
   | Assignment_to_non_mutable_value         (* 59 *)
+  | Unused_module of string                 (* 60 *)
+  | Unboxable_type_in_prim_decl of string   (* 61 *)
 ;;
 
 val parse_options : bool -> string -> unit;;

diff --git a/yacc/Makefile b/yacc/Makefile
index 9713d41b06b686cfb937fd6eea7289a88043cffa..6c32474b79a07c0590fde35f164703e48ba86e8a 100644 (file)
--- a/yacc/Makefile
+++ b/yacc/Makefile
@@ -20,31 +20,32 @@ include ../config/Makefile
 CC=$(BYTECC)
 CFLAGS=-DNDEBUG $(BYTECCCOMPOPTS)
 
-OBJS= closure.o error.o lalr.o lr0.o main.o mkpar.o output.o reader.o \
-  skeleton.o symtab.o verbose.o warshall.o
+OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \
+  mkpar.$(O) output.$(O) reader.$(O) \
+  skeleton.$(O) symtab.$(O) verbose.$(O) warshall.$(O)
 
 all: ocamlyacc$(EXE)
 
 ocamlyacc$(EXE): $(OBJS)
-       $(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc$(EXE) $(OBJS)
+       $(MKEXE) -o ocamlyacc$(EXE) $(OBJS) $(EXTRALIBS)
 
 version.h : ../VERSION
        echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h
 
 clean:
-       rm -f *.o ocamlyacc$(EXE) *~ version.h
+       rm -f *.$(O) ocamlyacc$(EXE) *~ version.h
 
 depend:
 
-closure.o: defs.h
-error.o: defs.h
-lalr.o: defs.h
-lr0.o: defs.h
-main.o: defs.h version.h
-mkpar.o: defs.h
-output.o: defs.h
-reader.o: defs.h
-skeleton.o: defs.h
-symtab.o: defs.h
-verbose.o: defs.h
-warshall.o: defs.h
+closure.$(O): defs.h
+error.$(O): defs.h
+lalr.$(O): defs.h
+lr0.$(O): defs.h
+main.$(O): defs.h version.h
+mkpar.$(O): defs.h
+output.$(O): defs.h
+reader.$(O): defs.h
+skeleton.$(O): defs.h
+symtab.$(O): defs.h
+verbose.$(O): defs.h
+warshall.$(O): defs.h

diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt
index 7c13f4c06031bcf027c09c137979abb34c358659..917f48bda357ad5bbf80f4d9f59380a52c67163e 100644 (file)
--- a/yacc/Makefile.nt
+++ b/yacc/Makefile.nt
@@ -13,39 +13,7 @@
 #*                                                                        *
 #**************************************************************************
 
-# Makefile for the parser generator.
-
-include ../config/Makefile
-
-OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \
-  mkpar.$(O) output.$(O) reader.$(O) \
-  skeleton.$(O) symtab.$(O) verbose.$(O) warshall.$(O)
-
-all: ocamlyacc.exe
-
-ocamlyacc.exe: $(OBJS)
-       $(MKEXE) -o ocamlyacc.exe $(OBJS) $(EXTRALIBS)
-
-version.h : ../VERSION
-       echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" >version.h
-
-clean:
-       rm -f *.$(O) ocamlyacc.exe *~ version.h
+include Makefile
 
 %.$(O): %.c
        $(BYTECC) -DNDEBUG -DNO_UNIX $(BYTECCCOMPOPTS) -c $<
-
-depend:
-
-closure.$(O): defs.h
-error.$(O): defs.h
-lalr.$(O): defs.h
-lr0.$(O): defs.h
-main.$(O): defs.h version.h
-mkpar.$(O): defs.h
-output.$(O): defs.h
-reader.$(O): defs.h
-skeleton.$(O): defs.h
-symtab.$(O): defs.h
-verbose.$(O): defs.h
-warshall.$(O): defs.h

diff --git a/yacc/defs.h b/yacc/defs.h
index 4168076515e556151aabe33cf5ecc5fb70da2baf..8377d05de5010bfb8d9aaa594b8abf8dfbc80425 100644 (file)
--- a/yacc/defs.h
+++ b/yacc/defs.h
@@ -210,6 +210,7 @@ extern char tflag;
 extern char vflag;
 extern char qflag;
 extern char sflag;
+extern char eflag;
 extern char big_endian;
 
 extern char *myname;
@@ -335,6 +336,7 @@ extern void output (void);
 extern void over_unionized (char *u_cptr) Noreturn;
 extern void prec_redeclared (void);
 extern void polymorphic_entry_point(char *s) Noreturn;
+extern void forbidden_conflicts (void);
 extern void reader (void);
 extern void reflexive_transitive_closure (unsigned int *R, int n);
 extern void reprec_warning (char *s);

diff --git a/yacc/error.c b/yacc/error.c
index 1b533a434278b6b34c3a61ab822a8e5a4413df0a..236908c08ed7d87ed42112fb982f17ae136f09cc 100644 (file)
--- a/yacc/error.c
+++ b/yacc/error.c
@@ -313,3 +313,11 @@ void polymorphic_entry_point(char *s)
             myname, s);
     done(1);
 }
+
+void forbidden_conflicts(void)
+{
+    fprintf(stderr,
+            "%s: the grammar has conflicts, but --strict was specified\n",
+            myname);
+    done(1);
+}

diff --git a/yacc/main.c b/yacc/main.c
index 329d397fbd8dc246bc1bfe792a2df6611fe9bef3..e7606dae447448db029daee920d4147f23e659b6 100644 (file)
--- a/yacc/main.c
+++ b/yacc/main.c
@@ -30,6 +30,7 @@ char rflag;
 char tflag;
 char vflag;
 char qflag;
+char eflag;
 char sflag;
 char big_endian;
 
@@ -160,7 +161,7 @@ void set_signals(void)
 
 void usage(void)
 {
-    fprintf(stderr, "usage: %s [-v] [-q] [-b file_prefix] filename\n",
+    fprintf(stderr, "usage: %s [-v] [--strict] [-q] [-b file_prefix] filename\n",
             myname);
     exit(1);
 }
@@ -184,6 +185,10 @@ void getargs(int argc, char **argv)
             return;
 
         case '-':
+            if (!strcmp (argv[i], "--strict")){
+              eflag = 1;
+              goto end_of_option;
+            }
             ++i;
             goto no_more_options;
 
@@ -457,6 +462,7 @@ int main(int argc, char **argv)
     lalr();
     make_parser();
     verbose();
+    if (eflag && SRtotal + RRtotal > 0) forbidden_conflicts();
     output();
     done(0);
     /*NOTREACHED*/